swagger2 2.2 → 2.2.1

raw patch · 10 files changed

+773/−721 lines, 10 filesdep +quickcheck-instancesdep +semigroupsdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: quickcheck-instances, semigroups

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−3
• src/Data/Swagger/Internal.hs +47/−18
• src/Data/Swagger/Internal/Schema.hs +12/−3
• src/Data/Swagger/Schema.hs +1/−0
• src/Data/Swagger/SchemaOptions.hs +29/−0
• swagger2.cabal +10/−3
• test/Data/Swagger/CommonTestTypes.hs +652/−0
• test/Data/Swagger/ParamSchemaSpec.hs +1/−82
• test/Data/Swagger/Schema/ValidationSpec.hs +3/−30
• test/Data/Swagger/SchemaSpec.hs +5/−582

@@ -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;

@@ -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

@@ -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 =

@@ -54,6 +54,7 @@   -- * Generic encoding configuration   SchemaOptions(..),   defaultSchemaOptions,+  fromAesonOptions, ) where  import Data.Swagger.Internal.Schema

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} -- | -- Module:      Data.Swagger.SchemaOptions -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>@@ -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+  }

@@ -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

@@ -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" }+    }+}+|]

@@ -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"-}-|]-

@@ -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))

@@ -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" }-    }-}-|]-