git.iko.soy/typeable/openapi3
on master help sign in
Merge pull request #17 from GetShopTV/to-param-#16

ToParamSchema class

commite89e06f0282fedea05a17c66faff81f3288c4116 authorNickolay Kudasov <fizruk@users.noreply.github.com> dateFri 11 Dec 2015, 00:05 (11 years ago) parentce3fe0a2091022
13 files changed+753−418
compare with master
unifiedsplit
src/Data/Swagger.hs+9−10 src/Data/Swagger/Internal.hs+155−173 src/Data/Swagger/Internal/ParamSchema.hs+204 src/Data/Swagger/Schema/Internal.hs → src/Data/Swagger/Internal/Schema.hs+47−107 src/Data/Swagger/Internal/Utils.hs+8 src/Data/Swagger/Lens.hs+47−38 src/Data/Swagger/ParamSchema.hs+23 src/Data/Swagger/Schema.hs+4−1 src/Data/Swagger/SchemaOptions.hs+55 swagger2.cabal+5−1 test/Data/Swagger/ParamSchemaSpec.hs+97 test/Data/Swagger/SchemaSpec.hs+18 test/Data/SwaggerSpec.hs+81−88
src/Data/Swagger.hs+9−10
@@ -6,6 +6,7 @@
66-- and Swagger-Codegen to generate clients in various languages.
77-- Additional utilities can also take advantage of the resulting files, such as testing tools.
88module Data.Swagger (
9+ module Data.Swagger.ParamSchema,
910 module Data.Swagger.Schema,
1011
1112 -- * Swagger specification
@@ -27,27 +28,24 @@ module Data.Swagger (
2728 Operation(..),
2829
2930 -- * Types and formats
30− ParameterType(..),
31− ItemsType(..),
32− SchemaType(..),
31+ SwaggerType(..),
3332 Format,
3433 CollectionFormat(..),
35− ItemsCollectionFormat(..),
3634
3735 -- * Parameters
38− Parameter(..),
39− ParameterSchema(..),
40− ParameterOtherSchema(..),
41− ParameterLocation(..),
36+ Param(..),
37+ ParamAnySchema(..),
38+ ParamOtherSchema(..),
39+ ParamLocation(..),
4240 ParamName,
4341 Items(..),
4442 Header(..),
4543 Example(..),
4644
47− -- * Schema
45+ -- * Schemas
46+ ParamSchema(..),
4847 Schema(..),
4948 SchemaItems(..),
50− SchemaCommon(..),
5149 Xml(..),
5250
5351 -- * Responses
@@ -81,6 +79,7 @@ module Data.Swagger (
8179 URL(..),
8280) where
8381
82+import Data.Swagger.ParamSchema
8483import Data.Swagger.Schema
8584
8685import Data.Swagger.Internal
src/Data/Swagger/Internal.hs+155−173
@@ -1,6 +1,8 @@
11{-# LANGUAGE DeriveGeneric #-}
22{-# LANGUAGE DeriveTraversable #-}
3+{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
46{-# LANGUAGE GeneralizedNewtypeDeriving #-}
57{-# LANGUAGE OverloadedStrings #-}
68{-# LANGUAGE RecordWildCards #-}
@@ -64,7 +66,7 @@ data Swagger = Swagger
6466
6567 -- | An object to hold parameters that can be used across operations.
6668 -- This property does not define global parameters for all operations.
67− , _parameters :: HashMap Text Parameter
69+ , _parameters :: HashMap Text Param
6870
6971 -- | An object to hold responses that can be used across operations.
7072 -- This property does not define global responses for all operations.
@@ -187,7 +189,7 @@ data PathItem = PathItem
187189 -- These parameters can be overridden at the operation level, but cannot be removed there.
188190 -- The list MUST NOT include duplicated parameters.
189191 -- A unique parameter is defined by a combination of a name and location.
190− , _pathItemParameters :: [Referenced Parameter]
192+ , _pathItemParameters :: [Referenced Param]
191193 } deriving (Eq, Show, Generic)
192194
193195-- | Describes a single API operation on a path.
@@ -228,7 +230,7 @@ data Operation = Operation
228230 -- the new definition will override it, but can never remove it.
229231 -- The list MUST NOT include duplicated parameters.
230232 -- A unique parameter is defined by a combination of a name and location.
231− , _operationParameters :: [Referenced Parameter]
233+ , _operationParameters :: [Referenced Param]
232234
233235 -- | The list of possible responses as they are returned from executing this operation.
234236 , _operationResponses :: Responses
@@ -255,81 +257,70 @@ newtype MimeList = MimeList { getMimeList :: [MediaType] }
255257
256258-- | Describes a single operation parameter.
257259-- A unique parameter is defined by a combination of a name and location.
258−data Parameter = Parameter
260+data Param = Param
259261 { -- | The name of the parameter.
260262 -- Parameter names are case sensitive.
261− _parameterName :: Text
263+ _paramName :: Text
262264
263265 -- | A brief description of the parameter.
264266 -- This could contain examples of use.
265267 -- GFM syntax can be used for rich text representation.
266− , _parameterDescription :: Maybe Text
268+ , _paramDescription :: Maybe Text
267269
268270 -- | Determines whether this parameter is mandatory.
269271 -- If the parameter is in "path", this property is required and its value MUST be true.
270272 -- Otherwise, the property MAY be included and its default value is @False@.
271− , _parameterRequired :: Maybe Bool
273+ , _paramRequired :: Maybe Bool
272274
273275 -- | Parameter schema.
274− , _parameterSchema :: ParameterSchema
276+ , _paramSchema :: ParamAnySchema
275277 } deriving (Eq, Show, Generic)
276278
277−data ParameterSchema
278− = ParameterBody (Referenced Schema)
279− | ParameterOther ParameterOtherSchema
279+data ParamAnySchema
280+ = ParamBody (Referenced Schema)
281+ | ParamOther ParamOtherSchema
280282 deriving (Eq, Show)
281283
282−data ParameterOtherSchema = ParameterOtherSchema
284+data ParamOtherSchema = ParamOtherSchema
283285 { -- | The location of the parameter.
284− _parameterOtherSchemaIn :: ParameterLocation
285−
286− -- | The type of the parameter.
287− -- Since the parameter is not located at the request body,
288− -- it is limited to simple types (that is, not an object).
289− -- If type is @'ParamFile'@, the @consumes@ MUST be either
290− -- "multipart/form-data" or " application/x-www-form-urlencoded"
291− -- and the parameter MUST be in @'ParameterFormData'@.
292− , _parameterOtherSchemaType :: ParameterType
293−
294− -- | The extending format for the previously mentioned type.
295− , _parameterOtherSchemaFormat :: Maybe Format
286+ _paramOtherSchemaIn :: ParamLocation
296287
297288 -- | Sets the ability to pass empty-valued parameters.
298− -- This is valid only for either @'ParameterQuery'@ or @'ParameterFormData'@
289+ -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
299290 -- and allows you to send a parameter with a name only or an empty value.
300291 -- Default value is @False@.
301− , _parameterOtherSchemaAllowEmptyValue :: Maybe Bool
302−
303− -- | __Required if type is @'ParamArray'@__.
304− -- Describes the type of items in the array.
305− , _parameterOtherSchemaItems :: Maybe Items
292+ , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
306293
307294 -- | Determines the format of the array if @'ParamArray'@ is used.
308295 -- Default value is csv.
309− , _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat
296+ , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)
310297
311− , _parameterOtherSchemaCommon :: SchemaCommon
298+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items
312299 } deriving (Eq, Show, Generic)
313300
314−data ParameterType
315− = ParamString
316− | ParamNumber
317− | ParamInteger
318− | ParamBoolean
319− | ParamArray
320− | ParamFile
321− deriving (Eq, Show)
301+data SwaggerType t where
302+ SwaggerString :: SwaggerType t
303+ SwaggerNumber :: SwaggerType t
304+ SwaggerInteger :: SwaggerType t
305+ SwaggerBoolean :: SwaggerType t
306+ SwaggerArray :: SwaggerType t
307+ SwaggerFile :: SwaggerType ParamOtherSchema
308+ SwaggerNull :: SwaggerType Schema
309+ SwaggerObject :: SwaggerType Schema
322310
323−data ParameterLocation
311+deriving instance Eq (SwaggerType t)
312+deriving instance Show (SwaggerType t)
313+
314+data ParamLocation
324315 = -- | Parameters that are appended to the URL.
325316 -- For example, in @/items?id=###@, the query parameter is @id@.
326− ParameterQuery
317+ ParamQuery
327318 -- | Custom headers that are expected as part of the request.
328− | ParameterHeader
319+ | ParamHeader
329320 -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
330321 -- This does not include the host or base path of the API.
331322 -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
332− | ParameterPath
323+ | ParamPath
333324 -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
334325 -- or @multipart/form-data@ are used as the content type of the request
335326 -- (in Swagger's definition, the @consumes@ property of an operation).
@@ -337,58 +328,36 @@ data ParameterLocation
337328 -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
338329 -- Form parameters have a different format based on the content-type used
339330 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
340− | ParameterFormData
331+ | ParamFormData
341332 deriving (Eq, Show)
342333
343334type Format = Text
344335
345336-- | Determines the format of the array.
346−data CollectionFormat
347− = CollectionCSV -- ^ Comma separated values: @foo,bar@.
348− | CollectionSSV -- ^ Space separated values: @foo bar@.
349− | CollectionTSV -- ^ Tab separated values: @foo\\tbar@.
350− | CollectionPipes -- ^ Pipe separated values: @foo|bar@.
351− | CollectionMulti -- ^ Corresponds to multiple parameter instances
352− -- instead of multiple values for a single instance @foo=bar&foo=baz@.
353− -- This is valid only for parameters in @'ParameterQuery'@ or @'ParameterFormData'@.
354− deriving (Eq, Show)
355−
356−data ItemsType
357− = ItemsString
358− | ItemsNumber
359− | ItemsInteger
360− | ItemsBoolean
361− | ItemsArray
362− deriving (Eq, Show)
363−
364−data SchemaType
365− = SchemaArray
366− | SchemaBoolean
367− | SchemaInteger
368− | SchemaNumber
369− | SchemaNull
370− | SchemaObject
371− | SchemaString
372− deriving (Eq, Show)
373−
374−-- | Determines the format of the nested array.
375−data ItemsCollectionFormat
376− = ItemsCollectionCSV -- ^ Comma separated values: @foo,bar@.
377− | ItemsCollectionSSV -- ^ Space separated values: @foo bar@.
378− | ItemsCollectionTSV -- ^ Tab separated values: @foo\\tbar@.
379− | ItemsCollectionPipes -- ^ Pipe separated values: @foo|bar@.
380− deriving (Eq, Show)
337+data CollectionFormat t where
338+ -- Comma separated values: @foo,bar@.
339+ CollectionCSV :: CollectionFormat t
340+ -- Space separated values: @foo bar@.
341+ CollectionSSV :: CollectionFormat t
342+ -- Tab separated values: @foo\\tbar@.
343+ CollectionTSV :: CollectionFormat t
344+ -- Pipe separated values: @foo|bar@.
345+ CollectionPipes :: CollectionFormat t
346+ -- Corresponds to multiple parameter instances
347+ -- instead of multiple values for a single instance @foo=bar&foo=baz@.
348+ -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
349+ CollectionMulti :: CollectionFormat Param
350+
351+deriving instance Eq (CollectionFormat t)
352+deriving instance Show (CollectionFormat t)
381353
382354type ParamName = Text
383355
384356data Schema = Schema
385− { _schemaType :: SchemaType
386− , _schemaFormat :: Maybe Format
387− , _schemaTitle :: Maybe Text
357+ { _schemaTitle :: Maybe Text
388358 , _schemaDescription :: Maybe Text
389359 , _schemaRequired :: [ParamName]
390360
391− , _schemaItems :: Maybe SchemaItems
392361 , _schemaAllOf :: Maybe [Schema]
393362 , _schemaProperties :: HashMap Text (Referenced Schema)
394363 , _schemaAdditionalProperties :: Maybe Schema
@@ -402,7 +371,7 @@ data Schema = Schema
402371 , _schemaMaxProperties :: Maybe Integer
403372 , _schemaMinProperties :: Maybe Integer
404373
405− , _schemaSchemaCommon :: SchemaCommon
374+ , _schemaParamSchema :: ParamSchema Schema SchemaItems
406375 } deriving (Eq, Show, Generic)
407376
408377data SchemaItems
@@ -410,26 +379,29 @@ data SchemaItems
410379 | SchemaItemsArray [Referenced Schema]
411380 deriving (Eq, Show)
412381
413−data SchemaCommon = SchemaCommon
382+data ParamSchema t items = ParamSchema
414383 { -- | Declares the value of the parameter that the server will use if none is provided,
415384 -- for example a @"count"@ to control the number of results per page might default to @100@
416385 -- if not supplied by the client in the request.
417386 -- (Note: "default" has no meaning for required parameters.)
418387 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
419− _schemaCommonDefault :: Maybe Value
420−
421− , _schemaCommonMaximum :: Maybe Scientific
422− , _schemaCommonExclusiveMaximum :: Maybe Bool
423− , _schemaCommonMinimum :: Maybe Scientific
424− , _schemaCommonExclusiveMinimum :: Maybe Bool
425− , _schemaCommonMaxLength :: Maybe Integer
426− , _schemaCommonMinLength :: Maybe Integer
427− , _schemaCommonPattern :: Maybe Text
428− , _schemaCommonMaxItems :: Maybe Integer
429− , _schemaCommonMinItems :: Maybe Integer
430− , _schemaCommonUniqueItems :: Maybe Bool
431− , _schemaCommonEnum :: Maybe [Value]
432− , _schemaCommonMultipleOf :: Maybe Scientific
388+ _paramSchemaDefault :: Maybe Value
389+
390+ , _paramSchemaType :: SwaggerType t
391+ , _paramSchemaFormat :: Maybe Format
392+ , _paramSchemaItems :: Maybe items
393+ , _paramSchemaMaximum :: Maybe Scientific
394+ , _paramSchemaExclusiveMaximum :: Maybe Bool
395+ , _paramSchemaMinimum :: Maybe Scientific
396+ , _paramSchemaExclusiveMinimum :: Maybe Bool
397+ , _paramSchemaMaxLength :: Maybe Integer
398+ , _paramSchemaMinLength :: Maybe Integer
399+ , _paramSchemaPattern :: Maybe Text
400+ , _paramSchemaMaxItems :: Maybe Integer
401+ , _paramSchemaMinItems :: Maybe Integer
402+ , _paramSchemaUniqueItems :: Maybe Bool
403+ , _paramSchemaEnum :: Maybe [Value]
404+ , _paramSchemaMultipleOf :: Maybe Scientific
433405 } deriving (Eq, Show, Generic)
434406
435407data Xml = Xml
@@ -461,21 +433,11 @@ data Xml = Xml
461433 } deriving (Eq, Show, Generic)
462434
463435data Items = Items
464− { -- | The internal type of the array.
465− _itemsType :: ItemsType
466−
467− -- | The extending format for the previously mentioned type.
468− , _itemsFormat :: Maybe Format
469−
470− -- | __Required if type is @'ItemsArray'@.__
471− -- Describes the type of items in the array.
472− , _itemsItems :: Maybe Items
473−
474− -- | Determines the format of the array if type array is used.
436+ { -- | Determines the format of the array if type array is used.
475437 -- Default value is @'ItemsCollectionCSV'@.
476− , _itemsCollectionFormat :: Maybe ItemsCollectionFormat
438+ _itemsCollectionFormat :: Maybe (CollectionFormat Items)
477439
478− , _itemsCommon :: SchemaCommon
440+ , _itemsParamSchema :: ParamSchema Items Items
479441 } deriving (Eq, Show, Generic)
480442
481443-- | A container for the expected responses of an operation.
@@ -521,21 +483,11 @@ data Header = Header
521483 { -- | A short description of the header.
522484 _headerDescription :: Maybe Text
523485
524− -- | The type of the object.
525− , _headerType :: ItemsType
526−
527− -- | The extending format for the previously mentioned type. See Data Type Formats for further details.
528− , _headerFormat :: Maybe Format
529−
530− -- | __Required if type is @'ItemsArray'@__.
531− -- Describes the type of items in the array.
532− , _headerItems :: Maybe Items
533−
534486 -- | Determines the format of the array if type array is used.
535487 -- Default value is @'ItemsCollectionCSV'@.
536− , _headerCollectionFormat :: Maybe ItemsCollectionFormat
488+ , _headerCollectionFormat :: Maybe (CollectionFormat Items)
537489
538− , _headerCommon :: SchemaCommon
490+ , _headerParamSchema :: ParamSchema Header Items
539491 } deriving (Eq, Show, Generic)
540492
541493data Example = Example { getExample :: Map MediaType Value }
@@ -657,15 +609,15 @@ instance Monoid Schema where
657609 mempty = genericMempty
658610 mappend = genericMappend
659611
660−instance Monoid SchemaCommon where
612+instance Monoid (ParamSchema t i) where
661613 mempty = genericMempty
662614 mappend = genericMappend
663615
664−instance Monoid Parameter where
616+instance Monoid Param where
665617 mempty = genericMempty
666618 mappend = genericMappend
667619
668−instance Monoid ParameterOtherSchema where
620+instance Monoid ParamOtherSchema where
669621 mempty = genericMempty
670622 mappend = genericMappend
671623
@@ -693,9 +645,9 @@ instance SwaggerMonoid Info
693645instance SwaggerMonoid Paths
694646instance SwaggerMonoid PathItem
695647instance SwaggerMonoid Schema
696−instance SwaggerMonoid SchemaCommon
697−instance SwaggerMonoid Parameter
698−instance SwaggerMonoid ParameterOtherSchema
648+instance SwaggerMonoid (ParamSchema t i)
649+instance SwaggerMonoid Param
650+instance SwaggerMonoid ParamOtherSchema
699651instance SwaggerMonoid Responses
700652instance SwaggerMonoid Response
701653instance SwaggerMonoid ExternalDocs
@@ -704,16 +656,12 @@ instance SwaggerMonoid Operation
704656instance SwaggerMonoid MimeList
705657deriving instance SwaggerMonoid URL
706658
707−instance SwaggerMonoid SchemaType where
708− swaggerMempty = SchemaNull
709− swaggerMappend _ y = y
710−
711−instance SwaggerMonoid ParameterType where
712− swaggerMempty = ParamString
659+instance SwaggerMonoid (SwaggerType t) where
660+ swaggerMempty = SwaggerString
713661 swaggerMappend _ y = y
714662
715−instance SwaggerMonoid ParameterLocation where
716− swaggerMempty = ParameterQuery
663+instance SwaggerMonoid ParamLocation where
664+ swaggerMempty = ParamQuery
717665 swaggerMappend _ y = y
718666
719667instance SwaggerMonoid (HashMap Text Schema) where
@@ -729,7 +677,7 @@ instance Monoid a => SwaggerMonoid (Referenced a) where
729677 swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
730678 swaggerMappend _ y = y
731679
732−instance SwaggerMonoid (HashMap Text Parameter) where
680+instance SwaggerMonoid (HashMap Text Param) where
733681 swaggerMempty = HashMap.empty
734682 swaggerMappend = HashMap.unionWith mappend
735683
@@ -753,28 +701,22 @@ instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
753701 swaggerMempty = HashMap.empty
754702 swaggerMappend = flip HashMap.union
755703
756−instance SwaggerMonoid ParameterSchema where
757− swaggerMempty = ParameterOther swaggerMempty
758− swaggerMappend (ParameterBody x) (ParameterBody y) = ParameterBody (swaggerMappend x y)
759− swaggerMappend (ParameterOther x) (ParameterOther y) = ParameterOther (swaggerMappend x y)
704+instance SwaggerMonoid ParamAnySchema where
705+ swaggerMempty = ParamOther swaggerMempty
706+ swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
707+ swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
760708 swaggerMappend _ y = y
761709
762710-- =======================================================================
763711-- TH derived ToJSON and FromJSON instances
764712-- =======================================================================
765713
766−deriveJSON (jsonPrefix "Parameter") ''ParameterLocation
767−deriveJSON (jsonPrefix "Param") ''ParameterType
714+deriveJSON (jsonPrefix "Param") ''ParamLocation
768715deriveJSON' ''Info
769716deriveJSON' ''Contact
770717deriveJSON' ''License
771−deriveJSON (jsonPrefix "Schema") ''SchemaType
772−deriveJSON (jsonPrefix "Items") ''ItemsType
773−deriveJSON (jsonPrefix "ItemsCollection") ''ItemsCollectionFormat
774−deriveJSON (jsonPrefix "Collection") ''CollectionFormat
775718deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
776719deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
777−deriveJSON' ''SchemaCommon
778720deriveJSONDefault ''Scheme
779721deriveJSON' ''Tag
780722deriveJSON' ''ExternalDocs
@@ -826,13 +768,13 @@ instance ToJSON SecurityScheme where
826768 toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
827769
828770instance ToJSON Schema where
829− toJSON = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema")
771+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
830772
831773instance ToJSON Header where
832− toJSON = genericToJSONWithSub "common" (jsonPrefix "header")
774+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
833775
834776instance ToJSON Items where
835− toJSON = genericToJSONWithSub "common" (jsonPrefix "items")
777+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items")
836778
837779instance ToJSON Host where
838780 toJSON (Host host mport) = toJSON $
@@ -846,15 +788,15 @@ instance ToJSON Paths where
846788instance ToJSON MimeList where
847789 toJSON (MimeList xs) = toJSON (map show xs)
848790
849−instance ToJSON Parameter where
850− toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter")
791+instance ToJSON Param where
792+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
851793
852−instance ToJSON ParameterSchema where
853− toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
854− toJSON (ParameterOther s) = toJSON s
794+instance ToJSON ParamAnySchema where
795+ toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
796+ toJSON (ParamOther s) = toJSON s
855797
856−instance ToJSON ParameterOtherSchema where
857− toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
798+instance ToJSON ParamOtherSchema where
799+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
858800
859801instance ToJSON SchemaItems where
860802 toJSON (SchemaItemsObject x) = toJSON x
@@ -873,6 +815,26 @@ instance ToJSON a => ToJSON (Referenced a) where
873815 toJSON (Ref ref) = toJSON ref
874816 toJSON (Inline x) = toJSON x
875817
818+instance ToJSON (SwaggerType t) where
819+ toJSON SwaggerArray = "array"
820+ toJSON SwaggerString = "string"
821+ toJSON SwaggerInteger = "integer"
822+ toJSON SwaggerNumber = "number"
823+ toJSON SwaggerBoolean = "boolean"
824+ toJSON SwaggerFile = "file"
825+ toJSON SwaggerNull = "null"
826+ toJSON SwaggerObject = "object"
827+
828+instance ToJSON (CollectionFormat t) where
829+ toJSON CollectionCSV = "csv"
830+ toJSON CollectionSSV = "ssv"
831+ toJSON CollectionTSV = "tsv"
832+ toJSON CollectionPipes = "pipes"
833+ toJSON CollectionMulti = "multi"
834+
835+instance ToJSON i => ToJSON (ParamSchema t i) where
836+ toJSON = genericToJSON (jsonPrefix "paramSchema")
837+
876838-- =======================================================================
877839-- Manual FromJSON instances
878840-- =======================================================================
@@ -913,7 +875,7 @@ instance FromJSON Swagger where
913875 , "security" .= ([] :: [SecurityRequirement])
914876 , "tags" .= ([] :: [Tag])
915877 , "definitions" .= (mempty :: HashMap Text Schema)
916− , "parameters" .= (mempty :: HashMap Text Parameter)
878+ , "parameters" .= (mempty :: HashMap Text Param)
917879 , "responses" .= (mempty :: HashMap Text Response)
918880 , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
919881 ] ) js
@@ -923,15 +885,15 @@ instance FromJSON SecurityScheme where
923885 parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
924886
925887instance FromJSON Schema where
926− parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema")
888+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
927889 `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
928890 , "required" .= ([] :: [ParamName]) ]
929891
930892instance FromJSON Header where
931− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header")
893+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
932894
933895instance FromJSON Items where
934− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items")
896+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items")
935897
936898instance FromJSON Host where
937899 parseJSON (String s) =
@@ -949,21 +911,21 @@ instance FromJSON Paths where
949911instance FromJSON MimeList where
950912 parseJSON js = (MimeList . map fromString) <$> parseJSON js
951913
952−instance FromJSON Parameter where
953− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter")
914+instance FromJSON Param where
915+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
954916
955−instance FromJSON ParameterSchema where
917+instance FromJSON ParamAnySchema where
956918 parseJSON js@(Object o) = do
957919 (i :: Text) <- o .: "in"
958920 case i of
959921 "body" -> do
960922 schema <- o .: "schema"
961− ParameterBody <$> parseJSON schema
962− _ -> ParameterOther <$> parseJSON js
923+ ParamBody <$> parseJSON schema
924+ _ -> ParamOther <$> parseJSON js
963925 parseJSON _ = empty
964926
965−instance FromJSON ParameterOtherSchema where
966− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
927+instance FromJSON ParamOtherSchema where
928+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
967929
968930instance FromJSON SchemaItems where
969931 parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js
@@ -991,7 +953,7 @@ instance FromJSON Operation where
991953
992954instance FromJSON PathItem where
993955 parseJSON = genericParseJSON (jsonPrefix "pathItem")
994− `withDefaults` [ "parameters" .= ([] :: [Parameter]) ]
956+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
995957
996958instance FromJSON Reference where
997959 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1005,3 +967,23 @@ instance FromJSON a => FromJSON (Referenced a) where
1005967instance FromJSON Xml where
1006968 parseJSON = genericParseJSON (jsonPrefix "xml")
1007969
970+instance FromJSON (SwaggerType Schema) where
971+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
972+
973+instance FromJSON (SwaggerType ParamOtherSchema) where
974+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
975+
976+instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
977+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
978+
979+instance FromJSON (CollectionFormat Param) where
980+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
981+
982+instance FromJSON (CollectionFormat Items) where
983+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
984+
985+-- NOTE: The constraint @FromJSON (SwaggerType t)@ is necessary here!
986+-- Without the constraint the general instance will be used
987+-- that only accepts common types (i.e. NOT object, null or file).
988+instance (FromJSON (SwaggerType t), FromJSON i) => FromJSON (ParamSchema t i) where
989+ parseJSON = genericParseJSON (jsonPrefix "ParamSchema")
src/Data/Swagger/Internal/ParamSchema.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE TypeSynonymInstances #-}
10+module Data.Swagger.Internal.ParamSchema where
11+
12+import Control.Lens
13+import Data.Aeson
14+import Data.Proxy
15+import GHC.Generics
16+
17+import Data.Int
18+import Data.Monoid
19+import Data.Scientific
20+import qualified Data.Text as T
21+import qualified Data.Text.Lazy as TL
22+import Data.Time
23+import Data.Word
24+
25+import Data.Swagger.Internal
26+import Data.Swagger.Lens
27+import Data.Swagger.SchemaOptions
28+
29+-- | Convert a type into a plain @'ParamSchema'@.
30+--
31+-- An example type and instance:
32+--
33+-- @
34+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
35+--
36+-- import Control.Lens
37+--
38+-- data Direction = Up | Down
39+--
40+-- instance ToParamSchema Direction where
41+-- toParamSchema = mempty
42+-- & schemaType .~ SwaggerString
43+-- & schemaEnum .~ [ \"Up\", \"Down\" ]
44+-- @
45+--
46+-- Instead of manually writing your @'ToParamSchema'@ instance you can
47+-- use a default generic implementation of @'toParamSchema'@.
48+--
49+-- To do that, simply add @deriving 'Generic'@ clause to your datatype
50+-- and declare a @'ToParamSchema'@ instance for your datatype without
51+-- giving definition for @'toParamSchema'@.
52+--
53+-- For instance, the previous example can be simplified into this:
54+--
55+-- @
56+-- {-\# LANGUAGE DeriveGeneric \#-}
57+--
58+-- import GHC.Generics (Generic)
59+--
60+-- data Direction = Up | Down deriving Generic
61+--
62+-- instance ToParamSchema Direction
63+-- @
64+class ToParamSchema a where
65+ -- | Convert a type into a plain parameter schema.
66+ toParamSchema :: proxy a -> ParamSchema t i
67+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t i
68+ toParamSchema = genericToParamSchema defaultSchemaOptions
69+
70+instance {-# OVERLAPPING #-} ToParamSchema String where
71+ toParamSchema _ = mempty & schemaType .~ SwaggerString
72+
73+instance ToParamSchema Bool where
74+ toParamSchema _ = mempty & schemaType .~ SwaggerBoolean
75+
76+instance ToParamSchema Integer where
77+ toParamSchema _ = mempty & schemaType .~ SwaggerInteger
78+
79+instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
80+instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
81+instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral
82+instance ToParamSchema Int32 where toParamSchema = toParamSchemaBoundedIntegral
83+instance ToParamSchema Int64 where toParamSchema = toParamSchemaBoundedIntegral
84+
85+instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
86+instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
87+instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
88+instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
89+instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
90+
91+-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
92+toParamSchemaBoundedIntegral :: forall proxy a t i. (Bounded a, Integral a) => proxy a -> ParamSchema t i
93+toParamSchemaBoundedIntegral _ = mempty
94+ & schemaType .~ SwaggerInteger
95+ & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
96+ & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
97+
98+instance ToParamSchema Char where
99+ toParamSchema _ = mempty
100+ & schemaType .~ SwaggerString
101+ & schemaMaxLength ?~ 1
102+ & schemaMinLength ?~ 1
103+
104+instance ToParamSchema Scientific where
105+ toParamSchema _ = mempty & schemaType .~ SwaggerNumber
106+
107+instance ToParamSchema Double where
108+ toParamSchema _ = mempty & schemaType .~ SwaggerNumber
109+
110+instance ToParamSchema Float where
111+ toParamSchema _ = mempty & schemaType .~ SwaggerNumber
112+
113+timeParamSchema :: String -> ParamSchema t i
114+timeParamSchema format = mempty
115+ & schemaType .~ SwaggerString
116+ & schemaFormat ?~ T.pack format
117+ & schemaMinLength ?~ toInteger (length format)
118+
119+-- |
120+-- >>> toParamSchema (Proxy :: Proxy Day) ^. schemaFormat
121+-- Just "yyyy-mm-dd"
122+instance ToParamSchema Day where
123+ toParamSchema _ = timeParamSchema "yyyy-mm-dd"
124+
125+-- |
126+-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
127+-- Just "yyyy-mm-ddThh:MM:ss"
128+instance ToParamSchema LocalTime where
129+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"
130+
131+-- |
132+-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
133+-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
134+instance ToParamSchema ZonedTime where
135+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
136+
137+-- |
138+-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
139+-- Just "yyyy-mm-ddThh:MM:ssZ"
140+instance ToParamSchema UTCTime where
141+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
142+
143+instance ToParamSchema NominalDiffTime where
144+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
145+
146+instance ToParamSchema T.Text where
147+ toParamSchema _ = toParamSchema (Proxy :: Proxy String)
148+
149+instance ToParamSchema TL.Text where
150+ toParamSchema _ = toParamSchema (Proxy :: Proxy String)
151+
152+instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
153+instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
154+instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
155+instance ToParamSchema a => ToParamSchema (Product a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
156+instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
157+instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
158+instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
159+
160+-- |
161+-- >>> encode (toParamSchema (Proxy :: Proxy ()) :: ParamSchema t Items)
162+-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
163+instance ToParamSchema () where
164+ toParamSchema _ = mempty
165+ & schemaType .~ SwaggerString
166+ & schemaEnum ?~ ["_"]
167+
168+-- | A configurable generic @'ParamSchema'@ creator.
169+genericToParamSchema :: forall proxy a t i. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t i
170+genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
171+
172+class GToParamSchema (f :: * -> *) where
173+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
174+
175+instance GToParamSchema f => GToParamSchema (D1 d f) where
176+ gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
177+
178+instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
179+ gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
180+
181+instance ToParamSchema c => GToParamSchema (K1 i c) where
182+ gtoParamSchema _ _ _ = toParamSchema (Proxy :: Proxy c)
183+
184+instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where
185+ gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
186+
187+class GEnumParamSchema (f :: * -> *) where
188+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
189+
190+instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
191+ genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
192+
193+instance Constructor c => GEnumParamSchema (C1 c U1) where
194+ genumParamSchema opts _ s = s
195+ & schemaType .~ SwaggerString
196+ & schemaEnum %~ addEnumValue tag
197+ where
198+ tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
199+
200+ addEnumValue x Nothing = Just [x]
201+ addEnumValue x (Just xs) = Just (x:xs)
202+
203+data Proxy3 a b c = Proxy3
204+
src/Data/Swagger/Schema/Internal.hs → src/Data/Swagger/Internal/Schema.hsrenamed+47−107
@@ -10,7 +10,7 @@
1010{-# LANGUAGE TypeFamilies #-}
1111{-# LANGUAGE TypeOperators #-}
1212{-# LANGUAGE TypeSynonymInstances #-}
13−module Data.Swagger.Schema.Internal where
13+module Data.Swagger.Internal.Schema where
1414
1515import Control.Lens
1616import Data.Aeson
@@ -32,7 +32,9 @@ import Data.Word
3232import GHC.Generics
3333
3434import Data.Swagger.Internal
35+import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
3536import Data.Swagger.Lens
37+import Data.Swagger.SchemaOptions
3638
3739-- | A @'Schema'@ with an optional name.
3840-- This name can be used in references.
@@ -58,7 +60,7 @@ named name schema = (Just name, schema)
5860--
5961-- instance ToSchema Coord where
6062-- toNamedSchema = (Just \"Coord\", mempty
61−-- & schemaType .~ SchemaObject
63+-- & schemaType .~ SwaggerObject
6264-- & schemaProperties .~
6365-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
6466-- , ("y", toSchemaRef (Proxy :: Proxy Double))
@@ -113,44 +115,27 @@ gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
113115
114116instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
115117 toNamedSchema _ = unnamed $ mempty
116− & schemaType .~ SchemaArray
118+ & schemaType .~ SwaggerArray
117119 & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
118120
119−instance {-# OVERLAPPING #-} ToSchema String where
120− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
121−
122−instance ToSchema Bool where
123− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean
124−
125−instance ToSchema Integer where
126− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger
127−
128−instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral
129−instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
130−instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
131−instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
132−instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
133−
134−instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral
135−instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
136−instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
137−instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
138−instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
139−
140−instance ToSchema Char where
141− toNamedSchema _ = unnamed $ mempty
142− & schemaType .~ SchemaString
143− & schemaMaxLength ?~ 1
144− & schemaMinLength ?~ 1
145−
146−instance ToSchema Scientific where
147− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
148−
149−instance ToSchema Double where
150− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
151−
152−instance ToSchema Float where
153− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
121+instance {-# OVERLAPPING #-} ToSchema String where toNamedSchema = unnamed . paramSchemaToSchema
122+instance ToSchema Bool where toNamedSchema = unnamed . paramSchemaToSchema
123+instance ToSchema Integer where toNamedSchema = unnamed . paramSchemaToSchema
124+instance ToSchema Int where toNamedSchema = unnamed . paramSchemaToSchema
125+instance ToSchema Int8 where toNamedSchema = unnamed . paramSchemaToSchema
126+instance ToSchema Int16 where toNamedSchema = unnamed . paramSchemaToSchema
127+instance ToSchema Int32 where toNamedSchema = unnamed . paramSchemaToSchema
128+instance ToSchema Int64 where toNamedSchema = unnamed . paramSchemaToSchema
129+instance ToSchema Word where toNamedSchema = unnamed . paramSchemaToSchema
130+instance ToSchema Word8 where toNamedSchema = unnamed . paramSchemaToSchema
131+instance ToSchema Word16 where toNamedSchema = unnamed . paramSchemaToSchema
132+instance ToSchema Word32 where toNamedSchema = unnamed . paramSchemaToSchema
133+instance ToSchema Word64 where toNamedSchema = unnamed . paramSchemaToSchema
134+
135+instance ToSchema Char where toNamedSchema = unnamed . paramSchemaToSchema
136+instance ToSchema Scientific where toNamedSchema = unnamed . paramSchemaToSchema
137+instance ToSchema Double where toNamedSchema = unnamed . paramSchemaToSchema
138+instance ToSchema Float where toNamedSchema = unnamed . paramSchemaToSchema
154139
155140instance ToSchema a => ToSchema (Maybe a) where
156141 toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
@@ -167,7 +152,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
167152
168153timeNamedSchema :: String -> String -> NamedSchema
169154timeNamedSchema name format = (Just name, mempty
170− & schemaType .~ SchemaString
155+ & schemaType .~ SwaggerString
171156 & schemaFormat ?~ T.pack format
172157 & schemaMinLength ?~ toInteger (length format))
173158
@@ -188,7 +173,7 @@ instance ToSchema LocalTime where
188173-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
189174instance ToSchema ZonedTime where
190175 toNamedSchema _ = (Just "ZonedTime", mempty
191− & schemaType .~ SchemaString
176+ & schemaType .~ SwaggerString
192177 & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
193178 & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
194179
@@ -201,11 +186,8 @@ instance ToSchema NominalDiffTime where
201186instance ToSchema UTCTime where
202187 toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
203188
204−instance ToSchema T.Text where
205− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
206−
207−instance ToSchema TL.Text where
208− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
189+instance ToSchema T.Text where toNamedSchema = unnamed . paramSchemaToSchema
190+instance ToSchema TL.Text where toNamedSchema = unnamed . paramSchemaToSchema
209191
210192instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int))
211193
@@ -215,7 +197,7 @@ instance ToSchema a => ToSchema (IntMap a) where
215197
216198instance ToSchema a => ToSchema (Map String a) where
217199 toNamedSchema _ = unnamed $ mempty
218− & schemaType .~ SchemaObject
200+ & schemaType .~ SwaggerObject
219201 & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
220202
221203instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
@@ -231,71 +213,19 @@ instance ToSchema a => ToSchema (Set a) where
231213
232214instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
233215
234−instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
235−instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
216+instance ToSchema All where toNamedSchema = unnamed . paramSchemaToSchema
217+instance ToSchema Any where toNamedSchema = unnamed . paramSchemaToSchema
218+
236219instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
237220instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
238221instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
239222instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
240223instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
241224
242−-- | Options that specify how to encode your type to Swagger schema.
243−data SchemaOptions = SchemaOptions
244− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
245− fieldLabelModifier :: String -> String
246− -- | Function applied to constructor tags which could be handy for lower-casing them for example.
247− , constructorTagModifier :: String -> String
248− -- | Function applied to datatype name.
249− , datatypeNameModifier :: String -> String
250− -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
251− -- will be encoded to a string enumeration schema with the constructor tags as possible values.
252− , allNullaryToStringTag :: Bool
253− -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).
254− -- Note that this option does not influence nested schemas, e.g. for these types
255− --
256− -- @
257− -- data Object = Object String deriving Generic
258− -- instance ToSchema Object
259− --
260− -- newtype Objects = Objects [Object] deriving Generic
261− -- instance ToSchema Objects where
262− -- toNamedSchema = genericToNamedSchema defaultSchemaOptions
263− -- { useReferences = False }
264− -- @
265− --
266− -- Schema for @Objects@ __will not__ inline @Object@ schema because
267− -- it is nested in a @[]@ schema.
268− , useReferences :: Bool
269− -- | Hide the field name when a record constructor has only one field, like a newtype.
270− , unwrapUnaryRecords :: Bool
271− }
272−
273−-- | Default encoding @'SchemaOptions'@.
274−--
275−-- @
276−-- 'SchemaOptions'
277−-- { 'fieldLabelModifier' = id
278−-- , 'constructorTagModifier' = id
279−-- , 'datatypeNameModifier' = id
280−-- , 'allNullaryToStringTag' = True
281−-- , 'useReferences' = True
282−-- , 'unwrapUnaryRecords' = False
283−-- }
284−-- @
285−defaultSchemaOptions :: SchemaOptions
286−defaultSchemaOptions = SchemaOptions
287− { fieldLabelModifier = id
288− , constructorTagModifier = id
289− , datatypeNameModifier = id
290− , allNullaryToStringTag = True
291− , useReferences = True
292− , unwrapUnaryRecords = False
293− }
294−
295225-- | Default schema for @'Bounded'@, @'Integral'@ types.
296226toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
297227toSchemaBoundedIntegral _ = mempty
298− & schemaType .~ SchemaInteger
228+ & schemaType .~ SwaggerInteger
299229 & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
300230 & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
301231
@@ -325,9 +255,19 @@ gdatatypeSchemaName opts _ = case name of
325255 where
326256 name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
327257
258+-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
259+paramSchemaToNamedSchema :: forall a d f proxy.
260+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
261+ => SchemaOptions -> proxy a -> NamedSchema
262+paramSchemaToNamedSchema opts proxy = (gdatatypeSchemaName opts (Proxy :: Proxy d), paramSchemaToSchema proxy)
263+
264+-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
265+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
266+paramSchemaToSchema _ = mempty & schemaParamSchema .~ toParamSchema (Proxy :: Proxy a)
267+
328268nullarySchema :: Schema
329269nullarySchema = mempty
330− & schemaType .~ SchemaArray
270+ & schemaType .~ SwaggerArray
331271 & schemaEnum ?~ [ toJSON () ]
332272
333273instance GToSchema U1 where
@@ -370,10 +310,10 @@ appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject
370310withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
371311withFieldSchema opts _ isRequiredField schema
372312 | T.null fieldName = schema
373− & schemaType .~ SchemaArray
313+ & schemaType .~ SwaggerArray
374314 & schemaItems %~ appendItem fieldSchemaRef
375315 | otherwise = schema
376− & schemaType .~ SchemaObject
316+ & schemaType .~ SwaggerObject
377317 & schemaProperties . at fieldName ?~ fieldSchemaRef
378318 & if isRequiredField
379319 then schemaRequired %~ (fieldName :)
@@ -401,7 +341,7 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
401341 (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
402342
403343 toStringTag schema = mempty
404− & schemaType .~ SchemaString
344+ & schemaType .~ SwaggerString
405345 & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
406346
407347type AllNullary = All
@@ -420,7 +360,7 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
420360gsumConToSchema :: forall c f proxy. Constructor c =>
421361 Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema)
422362gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema
423− & schemaType .~ SchemaObject
363+ & schemaType .~ SwaggerObject
424364 & schemaProperties . at tag ?~ tagSchemaRef
425365 & schemaMaxProperties ?~ 1
426366 & schemaMinProperties ?~ 1)
src/Data/Swagger/Internal/Utils.hs+8
@@ -52,6 +52,14 @@ deriveJSONDefault = deriveJSON (jsonPrefix "")
5252deriveJSON' :: Name -> Q [Dec]
5353deriveJSON' name = deriveJSON (jsonPrefix (nameBase name)) name
5454
55+parseOneOf :: ToJSON a => [a] -> Value -> Parser a
56+parseOneOf xs js =
57+ case lookup js ys of
58+ Nothing -> fail $ "invalid json: " ++ show js ++ " (expected one of " ++ show (map fst ys) ++ ")"
59+ Just x -> pure x
60+ where
61+ ys = zip (map toJSON xs) xs
62+
5563genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
5664genericToJSONWithSub sub opts x =
5765 case genericToJSON opts x of
src/Data/Swagger/Lens.hs+47−38
@@ -23,14 +23,14 @@ makeLenses ''Paths
2323makeLenses ''PathItem
2424makeLenses ''Tag
2525makeLenses ''Operation
26−makeLenses ''Parameter
27−makePrisms ''ParameterSchema
28−makeLenses ''ParameterOtherSchema
26+makeLenses ''Param
27+makePrisms ''ParamAnySchema
28+makeLenses ''ParamOtherSchema
2929makeLenses ''Items
3030makeLenses ''Header
3131makeLenses ''Schema
3232makePrisms ''SchemaItems
33−makeLenses ''SchemaCommon
33+makeLenses ''ParamSchema
3434makeLenses ''Xml
3535makeLenses ''Responses
3636makeLenses ''Response
@@ -51,57 +51,66 @@ instance HasDescription Response Text where description = responseDescript
5151instance HasDescription Info (Maybe Text) where description = infoDescription
5252instance HasDescription Tag (Maybe Text) where description = tagDescription
5353instance HasDescription Operation (Maybe Text) where description = operationDescription
54−instance HasDescription Parameter (Maybe Text) where description = parameterDescription
54+instance HasDescription Param (Maybe Text) where description = paramDescription
5555instance HasDescription Header (Maybe Text) where description = headerDescription
5656instance HasDescription Schema (Maybe Text) where description = schemaDescription
5757instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription
5858instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription
5959
60−class HasSchemaCommon s where
61− schemaCommon :: Lens' s SchemaCommon
60+class HasParamSchema s t i | s -> t i where
61+ parameterSchema :: Lens' s (ParamSchema t i)
6262
63−instance HasSchemaCommon Schema where schemaCommon = schemaSchemaCommon
64−instance HasSchemaCommon ParameterOtherSchema where schemaCommon = parameterOtherSchemaCommon
65−instance HasSchemaCommon Items where schemaCommon = itemsCommon
66−instance HasSchemaCommon Header where schemaCommon = headerCommon
67−instance HasSchemaCommon SchemaCommon where schemaCommon = id
63+instance HasParamSchema Schema Schema SchemaItems where parameterSchema = schemaParamSchema
64+instance HasParamSchema ParamOtherSchema ParamOtherSchema Items where parameterSchema = paramOtherSchemaParamSchema
65+instance HasParamSchema Items Items Items where parameterSchema = itemsParamSchema
66+instance HasParamSchema Header Header Items where parameterSchema = headerParamSchema
67+instance HasParamSchema (ParamSchema t i) t i where parameterSchema = id
6868
69−schemaDefault :: HasSchemaCommon s => Lens' s (Maybe Value)
70−schemaDefault = schemaCommon.schemaCommonDefault
69+schemaType :: HasParamSchema s t i => Lens' s (SwaggerType t)
70+schemaType = parameterSchema.paramSchemaType
7171
72−schemaMaximum :: HasSchemaCommon s => Lens' s (Maybe Scientific)
73−schemaMaximum = schemaCommon.schemaCommonMaximum
72+schemaFormat :: HasParamSchema s t i => Lens' s (Maybe Format)
73+schemaFormat = parameterSchema.paramSchemaFormat
7474
75−schemaExclusiveMaximum :: HasSchemaCommon s => Lens' s (Maybe Bool)
76−schemaExclusiveMaximum = schemaCommon.schemaCommonExclusiveMaximum
75+schemaItems :: HasParamSchema s t i => Lens' s (Maybe i)
76+schemaItems = parameterSchema.paramSchemaItems
7777
78−schemaMinimum :: HasSchemaCommon s => Lens' s (Maybe Scientific)
79−schemaMinimum = schemaCommon.schemaCommonMinimum
78+schemaDefault :: HasParamSchema s t i => Lens' s (Maybe Value)
79+schemaDefault = parameterSchema.paramSchemaDefault
8080
81−schemaExclusiveMinimum :: HasSchemaCommon s => Lens' s (Maybe Bool)
82−schemaExclusiveMinimum = schemaCommon.schemaCommonExclusiveMinimum
81+schemaMaximum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
82+schemaMaximum = parameterSchema.paramSchemaMaximum
8383
84−schemaMaxLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
85−schemaMaxLength = schemaCommon.schemaCommonMaxLength
84+schemaExclusiveMaximum :: HasParamSchema s t i => Lens' s (Maybe Bool)
85+schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum
8686
87−schemaMinLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
88−schemaMinLength = schemaCommon.schemaCommonMinLength
87+schemaMinimum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
88+schemaMinimum = parameterSchema.paramSchemaMinimum
8989
90−schemaPattern :: HasSchemaCommon s => Lens' s (Maybe Text)
91−schemaPattern = schemaCommon.schemaCommonPattern
90+schemaExclusiveMinimum :: HasParamSchema s t i => Lens' s (Maybe Bool)
91+schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum
9292
93−schemaMaxItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
94−schemaMaxItems = schemaCommon.schemaCommonMaxItems
93+schemaMaxLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
94+schemaMaxLength = parameterSchema.paramSchemaMaxLength
9595
96−schemaMinItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
97−schemaMinItems = schemaCommon.schemaCommonMinItems
96+schemaMinLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
97+schemaMinLength = parameterSchema.paramSchemaMinLength
9898
99−schemaUniqueItems :: HasSchemaCommon s => Lens' s (Maybe Bool)
100−schemaUniqueItems = schemaCommon.schemaCommonUniqueItems
99+schemaPattern :: HasParamSchema s t i => Lens' s (Maybe Text)
100+schemaPattern = parameterSchema.paramSchemaPattern
101101
102−schemaEnum :: HasSchemaCommon s => Lens' s (Maybe [Value])
103−schemaEnum = schemaCommon.schemaCommonEnum
102+schemaMaxItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
103+schemaMaxItems = parameterSchema.paramSchemaMaxItems
104104
105−schemaMultipleOf :: HasSchemaCommon s => Lens' s (Maybe Scientific)
106−schemaMultipleOf = schemaCommon.schemaCommonMultipleOf
105+schemaMinItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
106+schemaMinItems = parameterSchema.paramSchemaMinItems
107+
108+schemaUniqueItems :: HasParamSchema s t i => Lens' s (Maybe Bool)
109+schemaUniqueItems = parameterSchema.paramSchemaUniqueItems
110+
111+schemaEnum :: HasParamSchema s t i => Lens' s (Maybe [Value])
112+schemaEnum = parameterSchema.paramSchemaEnum
113+
114+schemaMultipleOf :: HasParamSchema s t i => Lens' s (Maybe Scientific)
115+schemaMultipleOf = parameterSchema.paramSchemaMultipleOf
107116
src/Data/Swagger/ParamSchema.hsnew file+23
@@ -0,0 +1,23 @@
1+-- |
2+-- Module: Data.Swagger.ParamSchema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
5+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
6+-- Stability: experimental
7+--
8+-- Types and functions for working with Swagger parameter schema.
9+module Data.Swagger.ParamSchema (
10+ -- * Encoding
11+ ToParamSchema(..),
12+
13+ -- * Generic schema encoding
14+ genericToParamSchema,
15+ toParamSchemaBoundedIntegral,
16+
17+ -- * Generic encoding configuration
18+ SchemaOptions(..),
19+ defaultSchemaOptions,
20+) where
21+
22+import Data.Swagger.Internal.ParamSchema
23+import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema.hs+4−1
@@ -19,10 +19,13 @@ module Data.Swagger.Schema (
1919 genericToNamedSchema,
2020 genericToNamedSchemaBoundedIntegral,
2121 toSchemaBoundedIntegral,
22+ paramSchemaToNamedSchema,
23+ paramSchemaToSchema,
2224
2325 -- * Generic encoding configuration
2426 SchemaOptions(..),
2527 defaultSchemaOptions,
2628) where
2729
28−import Data.Swagger.Schema.Internal
30+import Data.Swagger.Internal.Schema
31+import Data.Swagger.SchemaOptions
src/Data/Swagger/SchemaOptions.hsnew file+55
@@ -0,0 +1,55 @@
1+module Data.Swagger.SchemaOptions where
2+
3+-- | Options that specify how to encode your type to Swagger schema.
4+data SchemaOptions = SchemaOptions
5+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.
6+ fieldLabelModifier :: String -> String
7+ -- | Function applied to constructor tags which could be handy for lower-casing them for example.
8+ , constructorTagModifier :: String -> String
9+ -- | Function applied to datatype name.
10+ , datatypeNameModifier :: String -> String
11+ -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
12+ -- will be encoded to a string enumeration schema with the constructor tags as possible values.
13+ , allNullaryToStringTag :: Bool
14+ -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).
15+ -- Note that this option does not influence nested schemas, e.g. for these types
16+ --
17+ -- @
18+ -- data Object = Object String deriving Generic
19+ -- instance ToSchema Object
20+ --
21+ -- newtype Objects = Objects [Object] deriving Generic
22+ -- instance ToSchema Objects where
23+ -- toNamedSchema = genericToNamedSchema defaultSchemaOptions
24+ -- { useReferences = False }
25+ -- @
26+ --
27+ -- Schema for @Objects@ __will not__ inline @Object@ schema because
28+ -- it is nested in a @[]@ schema.
29+ , useReferences :: Bool
30+ -- | Hide the field name when a record constructor has only one field, like a newtype.
31+ , unwrapUnaryRecords :: Bool
32+ }
33+
34+-- | Default encoding @'SchemaOptions'@.
35+--
36+-- @
37+-- 'SchemaOptions'
38+-- { 'fieldLabelModifier' = id
39+-- , 'constructorTagModifier' = id
40+-- , 'datatypeNameModifier' = id
41+-- , 'allNullaryToStringTag' = True
42+-- , 'useReferences' = True
43+-- , 'unwrapUnaryRecords' = False
44+-- }
45+-- @
46+defaultSchemaOptions :: SchemaOptions
47+defaultSchemaOptions = SchemaOptions
48+ { fieldLabelModifier = id
49+ , constructorTagModifier = id
50+ , datatypeNameModifier = id
51+ , allNullaryToStringTag = True
52+ , useReferences = True
53+ , unwrapUnaryRecords = False
54+ }
55+
swagger2.cabal+5−1
@@ -21,12 +21,15 @@ library
2121 exposed-modules:
2222 Data.Swagger
2323 Data.Swagger.Lens
24+ Data.Swagger.ParamSchema
2425 Data.Swagger.Schema
26+ Data.Swagger.SchemaOptions
2527
2628 -- internal modules
2729 Data.Swagger.Internal
30+ Data.Swagger.Internal.Schema
31+ Data.Swagger.Internal.ParamSchema
2832 Data.Swagger.Internal.Utils
29− Data.Swagger.Schema.Internal
3033 build-depends: base == 4.*
3134 , aeson < 0.10
3235 , containers
@@ -56,6 +59,7 @@ test-suite spec
5659 , containers
5760 , unordered-containers
5861 , vector
62+ , lens
5963 other-modules:
6064 SpecCommon
6165 Data.SwaggerSpec
test/Data/Swagger/ParamSchemaSpec.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE QuasiQuotes #-}
6+module Data.Swagger.ParamSchemaSpec where
7+
8+import Data.Aeson
9+import Data.Aeson.QQ
10+import Data.Char
11+import Data.Proxy
12+import Data.Set (Set)
13+import GHC.Generics
14+
15+import Data.Swagger
16+
17+import SpecCommon
18+import Test.Hspec
19+
20+checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param Items) <=> js
22+
23+spec :: Spec
24+spec = do
25+ describe "Generic ToParamSchema" $ do
26+ context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
27+ context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
28+ context "Unary records" $ do
29+ context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
30+ context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
31+
32+main :: IO ()
33+main = hspec spec
34+
35+-- ========================================================================
36+-- Color (enum)
37+-- ========================================================================
38+data Color
39+ = Red
40+ | Green
41+ | Blue
42+ deriving (Generic, ToParamSchema)
43+
44+colorSchemaJSON :: Value
45+colorSchemaJSON = [aesonQQ|
46+{
47+ "type": "string",
48+ "enum": ["Red", "Green", "Blue"]
49+}
50+|]
51+
52+-- ========================================================================
53+-- Status (constructorTagModifier)
54+-- ========================================================================
55+
56+data Status = StatusOk | StatusError deriving (Generic)
57+
58+instance ToParamSchema Status where
59+ toParamSchema = genericToParamSchema defaultSchemaOptions
60+ { constructorTagModifier = map toLower . drop (length "Status") }
61+
62+statusSchemaJSON :: Value
63+statusSchemaJSON = [aesonQQ|
64+{
65+ "type": "string",
66+ "enum": ["ok", "error"]
67+}
68+|]
69+
70+-- ========================================================================
71+-- Email (newtype with unwrapUnaryRecords set to True)
72+-- ========================================================================
73+
74+newtype Email = Email { getEmail :: String }
75+ deriving (Generic, ToParamSchema)
76+
77+emailSchemaJSON :: Value
78+emailSchemaJSON = [aesonQQ|
79+{
80+ "type": "string"
81+}
82+|]
83+
84+-- ========================================================================
85+-- UserId (non-record newtype)
86+-- ========================================================================
87+
88+newtype UserId = UserId Integer
89+ deriving (Generic, ToParamSchema)
90+
91+userIdSchemaJSON :: Value
92+userIdSchemaJSON = [aesonQQ|
93+{
94+ "type": "integer"
95+}
96+|]
97+
test/Data/Swagger/SchemaSpec.hs+18
@@ -33,6 +33,7 @@ spec = do
3333 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
3434 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
3535 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
36+ context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
3637 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
3738 context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
3839 context "Unary records" $ do
@@ -49,6 +50,7 @@ spec = do
4950 context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
5051 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
5152 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
53+ context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
5254
5355main :: IO ()
5456main = hspec spec
@@ -137,6 +139,22 @@ colorSchemaJSON = [aesonQQ|
137139}
138140|]
139141
142+-- ========================================================================
143+-- Shade (paramSchemaToNamedSchema)
144+-- ========================================================================
145+
146+data Shade = Dim | Bright deriving (Generic, ToParamSchema)
147+
148+instance ToSchema Shade where toNamedSchema = paramSchemaToNamedSchema defaultSchemaOptions
149+
150+shadeSchemaJSON :: Value
151+shadeSchemaJSON = [aesonQQ|
152+{
153+ "type": "string",
154+ "enum": ["Dim", "Bright"]
155+}
156+|]
157+
140158-- ========================================================================
141159-- Paint (record with bounded enum property)
142160-- ========================================================================
test/Data/SwaggerSpec.hs+81−88
@@ -4,12 +4,15 @@
44{-# LANGUAGE QuasiQuotes #-}
55module Data.SwaggerSpec where
66
7+import Control.Lens
8+
79import Data.Aeson
810import Data.Aeson.QQ
911import Data.HashMap.Strict (HashMap)
1012import Data.Text (Text)
1113
1214import Data.Swagger
15+import Data.Swagger.Lens
1316import SpecCommon
1417import Test.Hspec
1518
@@ -25,7 +28,7 @@ spec = do
2528 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <~> schemaModelDictExampleJSON
2629 context "Model with Example" $ schemaWithExampleExample <~> schemaWithExampleExampleJSON
2730 describe "Definitions Object" $ definitionsExample <~> definitionsExampleJSON
28− describe "Parameters Definition Object" $ parametersDefinitionExample <~> parametersDefinitionExampleJSON
31+ describe "Parameters Definition Object" $ paramsDefinitionExample <~> paramsDefinitionExampleJSON
2932 describe "Responses Definition Object" $ responsesDefinitionExample <~> responsesDefinitionExampleJSON
3033 describe "Security Definitions Object" $ securityDefinitionsExample <~> securityDefinitionsExampleJSON
3134 describe "Swagger Object" $ do
@@ -131,27 +134,27 @@ operationExample = mempty
131134 , (405, Inline mempty { _responseDescription = "Invalid input" }) ] }
132135
133136 params = map Inline
134− [ Parameter
135− { _parameterName = "petId"
136− , _parameterDescription = Just "ID of pet that needs to be updated"
137− , _parameterRequired = Just True
138− , _parameterSchema = ParameterOther (stringSchema ParameterPath) }
139− , Parameter
140− { _parameterName = "name"
141− , _parameterDescription = Just "Updated name of the pet"
142− , _parameterRequired = Just False
143− , _parameterSchema = ParameterOther (stringSchema ParameterFormData) }
144− , Parameter
145− { _parameterName = "status"
146− , _parameterDescription = Just "Updated status of the pet"
147− , _parameterRequired = Just False
148− , _parameterSchema = ParameterOther (stringSchema ParameterFormData) }
137+ [ Param
138+ { _paramName = "petId"
139+ , _paramDescription = Just "ID of pet that needs to be updated"
140+ , _paramRequired = Just True
141+ , _paramSchema = ParamOther (stringSchema ParamPath) }
142+ , Param
143+ { _paramName = "name"
144+ , _paramDescription = Just "Updated name of the pet"
145+ , _paramRequired = Just False
146+ , _paramSchema = ParamOther (stringSchema ParamFormData) }
147+ , Param
148+ { _paramName = "status"
149+ , _paramDescription = Just "Updated status of the pet"
150+ , _paramRequired = Just False
151+ , _paramSchema = ParamOther (stringSchema ParamFormData) }
149152 ]
150153
154+ stringSchema :: ParamLocation -> ParamOtherSchema
151155 stringSchema i = mempty
152− { _parameterOtherSchemaIn = i
153− , _parameterOtherSchemaType = ParamString
154− }
156+ & paramOtherSchemaIn .~ i
157+ & schemaType .~ SwaggerString
155158
156159operationExampleJSON :: Value
157160operationExampleJSON = [aesonQQ|
@@ -217,9 +220,8 @@ operationExampleJSON = [aesonQQ|
217220
218221schemaPrimitiveExample :: Schema
219222schemaPrimitiveExample = mempty
220− { _schemaType = SchemaString
221− , _schemaFormat = Just "email"
222− }
223+ & schemaType .~ SwaggerString
224+ & schemaFormat ?~ "email"
223225
224226schemaPrimitiveExampleJSON :: Value
225227schemaPrimitiveExampleJSON = [aesonQQ|
@@ -231,17 +233,15 @@ schemaPrimitiveExampleJSON = [aesonQQ|
231233
232234schemaSimpleModelExample :: Schema
233235schemaSimpleModelExample = mempty
234− { _schemaType = SchemaObject
235− , _schemaRequired = [ "name" ]
236− , _schemaProperties =
237− [ ("name", Inline mempty
238− { _schemaType = SchemaString } )
236+ & schemaType .~ SwaggerObject
237+ & schemaRequired .~ [ "name" ]
238+ & schemaProperties .~
239+ [ ("name", Inline (mempty & schemaType .~ SwaggerString))
239240 , ("address", Ref (Reference "#/definitions/Address"))
240− , ("age", Inline mempty
241− { _schemaType = SchemaInteger
242− , _schemaFormat = Just "int32"
243− , _schemaSchemaCommon = mempty
244− { _schemaCommonMinimum = Just 0 } } ) ] }
241+ , ("age", Inline $ mempty
242+ & schemaMinimum ?~ 0
243+ & schemaType .~ SwaggerInteger
244+ & schemaFormat ?~ "int32" ) ]
245245
246246schemaSimpleModelExampleJSON :: Value
247247schemaSimpleModelExampleJSON = [aesonQQ|
@@ -268,9 +268,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
268268
269269schemaModelDictExample :: Schema
270270schemaModelDictExample = mempty
271− { _schemaType = SchemaObject
272− , _schemaAdditionalProperties = Just mempty
273− { _schemaType = SchemaString } }
271+ & schemaType .~ SwaggerObject
272+ & schemaAdditionalProperties ?~ (mempty & schemaType .~ SwaggerString)
274273
275274schemaModelDictExampleJSON :: Value
276275schemaModelDictExampleJSON = [aesonQQ|
@@ -283,14 +282,12 @@ schemaModelDictExampleJSON = [aesonQQ|
283282|]
284283
285284schemaWithExampleExample :: Schema
286−schemaWithExampleExample = mempty
287− { _schemaType = SchemaObject
288− , _schemaProperties =
289− [ ("id", Inline mempty
290− { _schemaType = SchemaInteger
291− , _schemaFormat = Just "int64" })
292− , ("name", Inline mempty
293− { _schemaType = SchemaString }) ]
285+schemaWithExampleExample = (mempty & schemaType .~ SwaggerObject)
286+ { _schemaProperties =
287+ [ ("id", Inline $ mempty
288+ & schemaType .~ SwaggerInteger
289+ & schemaFormat ?~ "int64" )
290+ , ("name", Inline (mempty & schemaType .~ SwaggerString)) ]
294291 , _schemaRequired = [ "name" ]
295292 , _schemaExample = Just [aesonQQ|
296293 {
@@ -329,21 +326,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
329326definitionsExample :: HashMap Text Schema
330327definitionsExample =
331328 [ ("Category", mempty
332− { _schemaType = SchemaObject
333− , _schemaProperties =
334− [ ("id", Inline mempty
335− { _schemaType = SchemaInteger
336− , _schemaFormat = Just "int64" })
337− , ("name", Inline mempty
338− { _schemaType = SchemaString }) ] })
329+ & schemaType .~ SwaggerObject
330+ & schemaProperties .~
331+ [ ("id", Inline $ mempty
332+ & schemaType .~ SwaggerInteger
333+ & schemaFormat ?~ "int64")
334+ , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] )
339335 , ("Tag", mempty
340− { _schemaType = SchemaObject
341− , _schemaProperties =
342− [ ("id", Inline mempty
343− { _schemaType = SchemaInteger
344− , _schemaFormat = Just "int64" })
345− , ("name", Inline mempty
346− { _schemaType = SchemaString }) ] }) ]
336+ & schemaType .~ SwaggerObject
337+ & schemaProperties .~
338+ [ ("id", Inline $ mempty
339+ & schemaType .~ SwaggerInteger
340+ & schemaFormat ?~ "int64")
341+ , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] ) ]
347342
348343definitionsExampleJSON :: Value
349344definitionsExampleJSON = [aesonQQ|
@@ -379,27 +374,27 @@ definitionsExampleJSON = [aesonQQ|
379374-- Parameters Definition object
380375-- =======================================================================
381376
382−parametersDefinitionExample :: HashMap Text Parameter
383−parametersDefinitionExample =
377+paramsDefinitionExample :: HashMap Text Param
378+paramsDefinitionExample =
384379 [ ("skipParam", mempty
385− { _parameterName = "skip"
386− , _parameterDescription = Just "number of items to skip"
387− , _parameterRequired = Just True
388− , _parameterSchema = ParameterOther mempty
389− { _parameterOtherSchemaIn = ParameterQuery
390− , _parameterOtherSchemaType = ParamInteger
391− , _parameterOtherSchemaFormat = Just "int32" } })
380+ { _paramName = "skip"
381+ , _paramDescription = Just "number of items to skip"
382+ , _paramRequired = Just True
383+ , _paramSchema = ParamOther $ mempty
384+ & paramOtherSchemaIn .~ ParamQuery
385+ & schemaType .~ SwaggerInteger
386+ & schemaFormat ?~ "int32" })
392387 , ("limitParam", mempty
393− { _parameterName = "limit"
394− , _parameterDescription = Just "max records to return"
395− , _parameterRequired = Just True
396− , _parameterSchema = ParameterOther mempty
397− { _parameterOtherSchemaIn = ParameterQuery
398− , _parameterOtherSchemaType = ParamInteger
399− , _parameterOtherSchemaFormat = Just "int32" } }) ]
388+ { _paramName = "limit"
389+ , _paramDescription = Just "max records to return"
390+ , _paramRequired = Just True
391+ , _paramSchema = ParamOther $ mempty
392+ & paramOtherSchemaIn .~ ParamQuery
393+ & schemaType .~ SwaggerInteger
394+ & schemaFormat ?~ "int32" }) ]
400395
401−parametersDefinitionExampleJSON :: Value
402−parametersDefinitionExampleJSON = [aesonQQ|
396+paramsDefinitionExampleJSON :: Value
397+paramsDefinitionExampleJSON = [aesonQQ|
403398{
404399 "skipParam": {
405400 "name": "skip",
@@ -500,30 +495,28 @@ swaggerExample = mempty
500495 { _operationResponses = mempty
501496 { _responsesResponses =
502497 [ (200, Inline mempty
503− { _responseSchema = Just $ Inline mempty
498+ { _responseSchema = Just $ Inline (mempty & schemaType .~ SwaggerObject)
504499 { _schemaExample = Just [aesonQQ|
505500 {
506501 "created": 100,
507502 "description": "get milk"
508503 } |]
509− , _schemaType = SchemaObject
510504 , _schemaDescription = Just "This is some real Todo right here"
511505 , _schemaProperties =
512− [ ("created", Inline mempty
513− { _schemaType = SchemaInteger
514− , _schemaFormat = Just "int32" })
515− , ("description", Inline mempty
516− { _schemaType = SchemaString }) ] }
506+ [ ("created", Inline $ mempty
507+ & schemaType .~ SwaggerInteger
508+ & schemaFormat ?~ "int32")
509+ , ("description", Inline (mempty & schemaType .~ SwaggerString)) ] }
517510 , _responseDescription = "OK" }) ] }
518511 , _operationProduces = Just (MimeList [ "application/json" ])
519512 , _operationParameters =
520513 [ Inline mempty
521− { _parameterRequired = Just True
522− , _parameterName = "id"
523− , _parameterDescription = Just "TodoId param"
524− , _parameterSchema = ParameterOther mempty
525− { _parameterOtherSchemaIn = ParameterPath
526− , _parameterOtherSchemaType = ParamString } } ]
514+ { _paramRequired = Just True
515+ , _paramName = "id"
516+ , _paramDescription = Just "TodoId param"
517+ , _paramSchema = ParamOther $ mempty
518+ & paramOtherSchemaIn .~ ParamPath
519+ & schemaType .~ SwaggerString } ]
527520 , _operationTags = [ "todo" ] } }) ] } }
528521
529522swaggerExampleJSON :: Value