@@ -1,4 +1,7 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
13{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFunctor #-}
25{-# LANGUAGE DeriveGeneric #-}
36{-# LANGUAGE DeriveTraversable #-}
47{-# LANGUAGE FlexibleContexts #-}
@@ -10,89 +13,127 @@
1013{-# LANGUAGE ScopedTypeVariables #-}
1114{-# LANGUAGE StandaloneDeriving #-}
1215{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ <710
19+{-# LANGUAGE PolyKinds #-}
20+#endif
21+#include "overlapping-compat.h"
1322module Data.Swagger.Internal where
1423
24+import Prelude ()
25+import Prelude.Compat
26+
27+import Control.Lens ((&), (.~), (?~))
1528import Control.Applicative
16−import Control.Monad
1729import Data.Aeson
18−import Data.Aeson.TH (deriveJSON)
1930import qualified Data.Aeson.Types as JSON
2031import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
21−import Data.HashMap.Strict (HashMap)
32+import Data.Hashable (Hashable)
2233import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
2335import Data.Map (Map)
2436import qualified Data.Map as Map
25−import Data.Monoid
37+import Data.Monoid (Monoid (..))
38+import Data.Semigroup.Compat (Semigroup (..))
2639import Data.Scientific (Scientific)
27−import Data.String (fromString)
40+import Data.String (IsString(..))
2841import Data.Text (Text)
2942import qualified Data.Text as Text
3043import GHC.Generics (Generic)
31−import Network (HostName, PortNumber)
44+import Network.Socket (HostName, PortNumber)
3245import Network.HTTP.Media (MediaType)
3346import Text.Read (readMaybe)
3447
48+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
49+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
50+
51+import Generics.SOP.TH (deriveGeneric)
52+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
53+ ,sopSwaggerGenericToJSONWithOpts
54+ ,sopSwaggerGenericParseJSON
55+ ,HasSwaggerAesonOptions(..)
56+ ,AesonDefaultValue(..)
57+ ,mkSwaggerAesonOptions
58+ ,saoAdditionalPairs
59+ ,saoSubObject)
3560import Data.Swagger.Internal.Utils
3661
62+#if MIN_VERSION_aeson(0,10,0)
63+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
64+#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding
65+#else
66+#define DEFINE_TOENCODING
67+#endif
68+
69+-- $setup
70+-- >>> :seti -XDataKinds
71+-- >>> import Data.Aeson
72+
73+-- | A list of definitions that can be used in references.
74+type Definitions = InsOrdHashMap Text
75+
3776-- | This is the root document object for the API specification.
3877data Swagger = Swagger
3978 { -- | Provides metadata about the API.
4079 -- The metadata can be used by the clients if needed.
41− _info :: Info
80+ _swaggerInfo :: Info
4281
4382 -- | The host (name or ip) serving the API. It MAY include a port.
4483 -- If the host is not included, the host serving the documentation is to be used (including the port).
45− , _host :: Maybe Host
84+ , _swaggerHost :: Maybe Host
4685
4786 -- | The base path on which the API is served, which is relative to the host.
4887 -- If it is not included, the API is served directly under the host.
4988 -- The value MUST start with a leading slash (/).
50− , _basePath :: Maybe FilePath
89+ , _swaggerBasePath :: Maybe FilePath
5190
5291 -- | The transfer protocol of the API.
5392 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
54− , _schemes :: Maybe [Scheme]
93+ , _swaggerSchemes :: Maybe [Scheme]
5594
5695 -- | A list of MIME types the APIs can consume.
5796 -- This is global to all APIs but can be overridden on specific API calls.
58− , _consumes :: MimeList
97+ , _swaggerConsumes :: MimeList
5998
6099 -- | A list of MIME types the APIs can produce.
61− -- This is global to all APIs but can be overridden on specific API calls.
62− , _produces :: MimeList
100+ -- This is global to all APIs but can be overridden on specific API calls.
101+ , _swaggerProduces :: MimeList
63102
64103 -- | The available paths and operations for the API.
65− , _paths :: Paths
104+ -- Holds the relative paths to the individual endpoints.
105+ -- The path is appended to the @'basePath'@ in order to construct the full URL.
106+ , _swaggerPaths :: InsOrdHashMap FilePath PathItem
66107
67108 -- | An object to hold data types produced and consumed by operations.
68− , _definitions :: HashMap Text Schema
109+ , _swaggerDefinitions :: Definitions Schema
69110
70111 -- | An object to hold parameters that can be used across operations.
71112 -- This property does not define global parameters for all operations.
72− , _parameters :: HashMap Text Param
113+ , _swaggerParameters :: Definitions Param
73114
74115 -- | An object to hold responses that can be used across operations.
75116 -- This property does not define global responses for all operations.
76− , _responses :: HashMap Text Response
117+ , _swaggerResponses :: Definitions Response
77118
78119 -- | Security scheme definitions that can be used across the specification.
79− , _securityDefinitions :: HashMap Text SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
80121
81122 -- | A declaration of which security schemes are applied for the API as a whole.
82123 -- The list of values describes alternative security schemes that can be used
83124 -- (that is, there is a logical OR between the security requirements).
84125 -- Individual operations can override this definition.
85− , _security :: [SecurityRequirement]
126+ , _swaggerSecurity :: [SecurityRequirement]
86127
87128 -- | A list of tags used by the specification with additional metadata.
88129 -- The order of the tags can be used to reflect on their order by the parsing tools.
89130 -- Not all tags that are used by the Operation Object must be declared.
90131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
91132 -- Each tag name in the list MUST be unique.
92− , _tags :: [Tag]
133+ , _swaggerTags :: InsOrdHashSet Tag
93134
94135 -- | Additional external documentation.
95− , _externalDocs :: Maybe ExternalDocs
136+ , _swaggerExternalDocs :: Maybe ExternalDocs
96137 } deriving (Eq, Show, Generic, Data, Typeable)
97138
98139-- | The object provides metadata about the API.
@@ -141,12 +182,18 @@ data License = License
141182 , _licenseUrl :: Maybe URL
142183 } deriving (Eq, Show, Generic, Data, Typeable)
143184
185+instance IsString License where
186+ fromString s = License (fromString s) Nothing
187+
144188-- | The host (name or ip) serving the API. It MAY include a port.
145189data Host = Host
146190 { _hostName :: HostName -- ^ Host name.
147191 , _hostPort :: Maybe PortNumber -- ^ Optional port.
148192 } deriving (Eq, Show, Generic, Typeable)
149193
194+instance IsString Host where
195+ fromString s = Host s Nothing
196+
150197hostConstr :: Constr
151198hostConstr = mkConstr hostDataType "Host" [] Prefix
152199
@@ -168,13 +215,6 @@ data Scheme
168215 | Wss
169216 deriving (Eq, Show, Generic, Data, Typeable)
170217
171−-- | The available paths and operations for the API.
172−data Paths = Paths
173− { -- | Holds the relative paths to the individual endpoints.
174− -- The path is appended to the @'basePath'@ in order to construct the full URL.
175− _pathsMap :: HashMap FilePath PathItem
176− } deriving (Eq, Show, Generic, Data, Typeable)
177−
178218-- | Describes the operations available on a single path.
179219-- A @'PathItem'@ may be empty, due to ACL constraints.
180220-- The path itself is still exposed to the documentation viewer
@@ -212,7 +252,7 @@ data PathItem = PathItem
212252data Operation = Operation
213253 { -- | A list of tags for API documentation control.
214254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
215− _operationTags :: [Text]
255+ _operationTags :: InsOrdHashSet TagName
216256
217257 -- | A short summary of what the operation does.
218258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -269,7 +309,7 @@ data Operation = Operation
269309 } deriving (Eq, Show, Generic, Data, Typeable)
270310
271311newtype MimeList = MimeList { getMimeList :: [MediaType] }
272− deriving (Eq, Show, Monoid, Typeable)
312+ deriving (Eq, Show, Semigroup, Monoid, Typeable)
273313
274314mimeListConstr :: Constr
275315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -320,12 +360,92 @@ data ParamOtherSchema = ParamOtherSchema
320360 -- Default value is @False@.
321361 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
322362
323− -- | Determines the format of the array if @'ParamArray'@ is used.
324− -- Default value is csv.
325− , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)
363+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364+ } deriving (Eq, Show, Generic, Typeable, Data)
365+
366+-- | Items for @'SwaggerArray'@ schemas.
367+--
368+-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
369+-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
370+-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
371+-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
372+--
373+-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
374+--
375+-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376+data SwaggerItems t where
377+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
380+ deriving (Typeable)
381+
382+deriving instance Eq (SwaggerItems t)
383+deriving instance Show (SwaggerItems t)
384+--deriving instance Typeable (SwaggerItems t)
385+
386+swaggerItemsPrimitiveConstr :: Constr
387+swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388+
389+swaggerItemsObjectConstr :: Constr
390+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391+
392+swaggerItemsArrayConstr :: Constr
393+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394+
395+swaggerItemsDataType :: DataType
396+swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397+
398+-- Note: unfortunately we have to write these Data instances by hand,
399+-- to get better contexts / avoid duplicate name when using standalone deriving
400+
401+instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where
402+ -- TODO: define gfoldl
403+ gunfold k z c = case constrIndex c of
404+ 1 -> k (k (z SwaggerItemsPrimitive))
405+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406+ toConstr _ = swaggerItemsPrimitiveConstr
407+ dataTypeOf _ = swaggerItemsDataType
408+
409+-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
410+instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
411+ -- TODO: define gfoldl
412+ gunfold k z c = case constrIndex c of
413+ 1 -> k (k (z SwaggerItemsPrimitive))
414+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
415+ toConstr _ = swaggerItemsPrimitiveConstr
416+ dataTypeOf _ = swaggerItemsDataType
326417
327− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items
328− } deriving (Eq, Show, Generic, Data, Typeable)
418+instance Data (SwaggerItems 'SwaggerKindSchema) where
419+ gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
420+ gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
421+ gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
422+
423+ gunfold k z c = case constrIndex c of
424+ 2 -> k (z SwaggerItemsObject)
425+ 3 -> k (z SwaggerItemsArray)
426+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."
427+
428+ toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"
429+ toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
430+ toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
431+
432+ dataTypeOf _ = swaggerItemsDataType
433+
434+-- | Type used as a kind to avoid overlapping instances.
435+data SwaggerKind t
436+ = SwaggerKindNormal t
437+ | SwaggerKindParamOtherSchema
438+ | SwaggerKindSchema
439+ deriving (Typeable)
440+
441+deriving instance Typeable 'SwaggerKindNormal
442+deriving instance Typeable 'SwaggerKindParamOtherSchema
443+deriving instance Typeable 'SwaggerKindSchema
444+
445+type family SwaggerKindType (k :: SwaggerKind *) :: *
446+type instance SwaggerKindType ('SwaggerKindNormal t) = t
447+type instance SwaggerKindType 'SwaggerKindSchema = Schema
448+type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema
329449
330450data SwaggerType t where
331451 SwaggerString :: SwaggerType t
@@ -333,81 +453,47 @@ data SwaggerType t where
333453 SwaggerInteger :: SwaggerType t
334454 SwaggerBoolean :: SwaggerType t
335455 SwaggerArray :: SwaggerType t
336− SwaggerFile :: SwaggerType ParamOtherSchema
337− SwaggerNull :: SwaggerType Schema
338− SwaggerObject :: SwaggerType Schema
456+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457+ SwaggerNull :: SwaggerType 'SwaggerKindSchema
458+ SwaggerObject :: SwaggerType 'SwaggerKindSchema
459+ deriving (Typeable)
339460
340461deriving instance Eq (SwaggerType t)
341462deriving instance Show (SwaggerType t)
342−deriving instance Typeable (SwaggerType t)
343463
344−swaggerStringConstr :: DataType -> Constr
345−swaggerStringConstr dt = mkConstr dt "SwaggerString" [] Prefix
464+swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465+swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
346466
347−swaggerNumberConstr :: DataType -> Constr
348−swaggerNumberConstr dt = mkConstr dt "SwaggerNumber" [] Prefix
467+swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
468+swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
349469
350−swaggerIntegerConstr :: DataType -> Constr
351−swaggerIntegerConstr dt = mkConstr dt "SwaggerInteger" [] Prefix
470+swaggerCommonTypes :: [SwaggerType k]
471+swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
352472
353−swaggerBooleanConstr :: DataType -> Constr
354−swaggerBooleanConstr dt = mkConstr dt "SwaggerBoolean" [] Prefix
473+swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
474+swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
355475
356−swaggerArrayConstr :: DataType -> Constr
357−swaggerArrayConstr dt = mkConstr dt "SwaggerArray" [] Prefix
476+swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
477+swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
358478
359−swaggerFileConstr :: DataType -> Constr
360−swaggerFileConstr dt = mkConstr dt "SwaggerFile" [] Prefix
479+swaggerTypeConstrs :: [Constr]
480+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
481+ ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
361482
362−swaggerNullConstr :: DataType -> Constr
363−swaggerNullConstr dt = mkConstr dt "SwaggerNull" [] Prefix
483+instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
484+ gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485+ toConstr = swaggerTypeConstr
486+ dataTypeOf = swaggerTypeDataType
364487
365−swaggerObjectConstr :: DataType -> Constr
366−swaggerObjectConstr dt = mkConstr dt "SwaggerObject" [] Prefix
488+instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
489+ gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490+ toConstr = swaggerTypeConstr
491+ dataTypeOf = swaggerTypeDataType
367492
368−swaggerTypeDataType :: [DataType -> Constr] -> DataType
369−swaggerTypeDataType extra = dt
370− where
371− dt = mkDataType "Data.Swagger.SwaggerType" $ map ($ dt) $
372− [ swaggerStringConstr, swaggerNumberConstr, swaggerIntegerConstr, swaggerBooleanConstr , swaggerArrayConstr ]
373− ++ extra
374−
375−swaggerTypeToConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
376−swaggerTypeToConstr t = case t of
377− SwaggerString -> swaggerStringConstr dt
378− SwaggerNumber -> swaggerNumberConstr dt
379− SwaggerInteger -> swaggerIntegerConstr dt
380− SwaggerBoolean -> swaggerBooleanConstr dt
381− SwaggerArray -> swaggerArrayConstr dt
382− SwaggerFile -> swaggerFileConstr dt
383− SwaggerNull -> swaggerNullConstr dt
384− SwaggerObject -> swaggerObjectConstr dt
385− where
386− dt = dataTypeOf t
387−
388−instance Data (SwaggerType Items) where
389− gunfold = gunfoldEnum "SwaggerType Items" $ zip [1..]
390− [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
391− toConstr = swaggerTypeToConstr
392− dataTypeOf _ = swaggerTypeDataType []
393−
394−instance Data (SwaggerType Header) where
395− gunfold = gunfoldEnum "SwaggerType Header" $ zip [1..]
396− [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
397− toConstr = swaggerTypeToConstr
398− dataTypeOf _ = swaggerTypeDataType []
399−
400−instance Data (SwaggerType ParamOtherSchema) where
401− gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" $ zip [1..]
402− [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray, SwaggerFile]
403− toConstr = swaggerTypeToConstr
404− dataTypeOf _ = swaggerTypeDataType [swaggerFileConstr]
405−
406−instance Data (SwaggerType Schema) where
407− gunfold = gunfoldEnum "SwaggerType Schema" $ zip [1, 2, 3, 4, 5, 7, 8]
408− [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
409− toConstr = swaggerTypeToConstr
410− dataTypeOf _ = swaggerTypeDataType [swaggerNullConstr, swaggerObjectConstr]
493+instance Data (SwaggerType 'SwaggerKindSchema) where
494+ gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495+ toConstr = swaggerTypeConstr
496+ dataTypeOf = swaggerTypeDataType
411497
412498data ParamLocation
413499 = -- | Parameters that are appended to the URL.
@@ -444,40 +530,28 @@ data CollectionFormat t where
444530 -- Corresponds to multiple parameter instances
445531 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
446532 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
447− CollectionMulti :: CollectionFormat Param
533+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
534+ deriving (Typeable)
448535
449536deriving instance Eq (CollectionFormat t)
450537deriving instance Show (CollectionFormat t)
451−deriving instance Typeable (CollectionFormat t)
452−
453−collectionCsvConstr :: Constr
454−collectionCsvConstr = mkConstr collectionFormatDataType "CollectionCSV" [] Prefix
455−
456−collectionSsvConstr :: Constr
457−collectionSsvConstr = mkConstr collectionFormatDataType "CollectionSSV" [] Prefix
458538
459−collectionTsvConstr :: Constr
460−collectionTsvConstr = mkConstr collectionFormatDataType "CollectionTSV" [] Prefix
461−
462−collectionPipesConstr :: Constr
463−collectionPipesConstr = mkConstr collectionFormatDataType "CollectionPipes" [] Prefix
539+collectionFormatConstr :: CollectionFormat t -> Constr
540+collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
464541
465542collectionFormatDataType :: DataType
466−collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat"
467− [ collectionCsvConstr, collectionSsvConstr, collectionTsvConstr, collectionPipesConstr ]
468−
469−instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where
470− gunfold = gunfoldEnum "CollectionFormat" $ zip [1..]
471− [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
543+collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
544+ map collectionFormatConstr collectionCommonFormats
472545
473− toConstr CollectionCSV = collectionCsvConstr
474− toConstr CollectionSSV = collectionSsvConstr
475− toConstr CollectionTSV = collectionTsvConstr
476− toConstr CollectionPipes = collectionPipesConstr
546+collectionCommonFormats :: [CollectionFormat t]
547+collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
477548
549+instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
550+ gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551+ toConstr = collectionFormatConstr
478552 dataTypeOf _ = collectionFormatDataType
479553
480−deriving instance {-# OVERLAPPING #-} Data (CollectionFormat Param)
554+deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
481555
482556type ParamName = Text
483557
@@ -486,9 +560,9 @@ data Schema = Schema
486560 , _schemaDescription :: Maybe Text
487561 , _schemaRequired :: [ParamName]
488562
489− , _schemaAllOf :: Maybe [Schema]
490− , _schemaProperties :: HashMap Text (Referenced Schema)
491− , _schemaAdditionalProperties :: Maybe Schema
563+ , _schemaAllOf :: Maybe [Referenced Schema]
564+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
492566
493567 , _schemaDiscriminator :: Maybe Text
494568 , _schemaReadOnly :: Maybe Bool
@@ -499,15 +573,20 @@ data Schema = Schema
499573 , _schemaMaxProperties :: Maybe Integer
500574 , _schemaMinProperties :: Maybe Integer
501575
502− , _schemaParamSchema :: ParamSchema Schema SchemaItems
576+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
503577 } deriving (Eq, Show, Generic, Data, Typeable)
504578
505−data SchemaItems
506− = SchemaItemsObject (Referenced Schema)
507− | SchemaItemsArray [Referenced Schema]
508− deriving (Eq, Show, Generic, Data, Typeable)
579+-- | A @'Schema'@ with an optional name.
580+-- This name can be used in references.
581+data NamedSchema = NamedSchema
582+ { _namedSchemaName :: Maybe Text
583+ , _namedSchemaSchema :: Schema
584+ } deriving (Eq, Show, Generic, Data, Typeable)
509585
510−data ParamSchema t items = ParamSchema
586+-- | Regex pattern for @string@ type.
587+type Pattern = Text
588+
589+data ParamSchema (t :: SwaggerKind *) = ParamSchema
511590 { -- | Declares the value of the parameter that the server will use if none is provided,
512591 -- for example a @"count"@ to control the number of results per page might default to @100@
513592 -- if not supplied by the client in the request.
@@ -515,16 +594,16 @@ data ParamSchema t items = ParamSchema
515594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
516595 _paramSchemaDefault :: Maybe Value
517596
518− , _paramSchemaType :: SwaggerType t
597+ , _paramSchemaType :: Maybe (SwaggerType t)
519598 , _paramSchemaFormat :: Maybe Format
520− , _paramSchemaItems :: Maybe items
599+ , _paramSchemaItems :: Maybe (SwaggerItems t)
521600 , _paramSchemaMaximum :: Maybe Scientific
522601 , _paramSchemaExclusiveMaximum :: Maybe Bool
523602 , _paramSchemaMinimum :: Maybe Scientific
524603 , _paramSchemaExclusiveMinimum :: Maybe Bool
525604 , _paramSchemaMaxLength :: Maybe Integer
526605 , _paramSchemaMinLength :: Maybe Integer
527− , _paramSchemaPattern :: Maybe Text
606+ , _paramSchemaPattern :: Maybe Pattern
528607 , _paramSchemaMaxItems :: Maybe Integer
529608 , _paramSchemaMinItems :: Maybe Integer
530609 , _paramSchemaUniqueItems :: Maybe Bool
@@ -532,11 +611,11 @@ data ParamSchema t items = ParamSchema
532611 , _paramSchemaMultipleOf :: Maybe Scientific
533612 } deriving (Eq, Show, Generic, Typeable)
534613
535−deriving instance (Data t, Data (SwaggerType t), Data i) => Data (ParamSchema t i)
614+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
536615
537616data Xml = Xml
538617 { -- | Replaces the name of the element/attribute used for the described schema property.
539− -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list.
618+ -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
540619 -- When defined alongside type being array (outside the items),
541620 -- it will affect the wrapping element and only if wrapped is true.
542621 -- If wrapped is false, it will be ignored.
@@ -562,14 +641,6 @@ data Xml = Xml
562641 , _xmlWrapped :: Maybe Bool
563642 } deriving (Eq, Show, Generic, Data, Typeable)
564643
565−data Items = Items
566− { -- | Determines the format of the array if type array is used.
567− -- Default value is @'ItemsCollectionCSV'@.
568− _itemsCollectionFormat :: Maybe (CollectionFormat Items)
569−
570− , _itemsParamSchema :: ParamSchema Items Items
571− } deriving (Eq, Show, Generic, Data, Typeable)
572−
573644-- | A container for the expected responses of an operation.
574645-- The container maps a HTTP response code to the expected response.
575646-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
@@ -582,7 +653,7 @@ data Responses = Responses
582653
583654 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
584655 -- Describes the expected response for those HTTP status codes.
585− , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
656+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
586657 } deriving (Eq, Show, Generic, Data, Typeable)
587658
588659type HttpStatusCode = Int
@@ -601,23 +672,22 @@ data Response = Response
601672 , _responseSchema :: Maybe (Referenced Schema)
602673
603674 -- | A list of headers that are sent with the response.
604− , _responseHeaders :: HashMap HeaderName Header
675+ , _responseHeaders :: InsOrdHashMap HeaderName Header
605676
606677 -- | An example of the response message.
607678 , _responseExamples :: Maybe Example
608679 } deriving (Eq, Show, Generic, Data, Typeable)
609680
681+instance IsString Response where
682+ fromString s = Response (fromString s) Nothing mempty Nothing
683+
610684type HeaderName = Text
611685
612686data Header = Header
613687 { -- | A short description of the header.
614688 _headerDescription :: Maybe Text
615689
616− -- | Determines the format of the array if type array is used.
617− -- Default value is @'ItemsCollectionCSV'@.
618− , _headerCollectionFormat :: Maybe (CollectionFormat Items)
619−
620− , _headerParamSchema :: ParamSchema Header Items
690+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
621691 } deriving (Eq, Show, Generic, Data, Typeable)
622692
623693data Example = Example { getExample :: Map MediaType Value }
@@ -668,7 +738,7 @@ data OAuth2Params = OAuth2Params
668738 _oauth2Flow :: OAuth2Flow
669739
670740 -- | The available scopes for the OAuth2 security scheme.
671− , _oauth2Scopes :: HashMap Text Text
741+ , _oauth2Scopes :: InsOrdHashMap Text Text
672742 } deriving (Eq, Show, Generic, Data, Typeable)
673743
674744data SecuritySchemeType
@@ -685,18 +755,37 @@ data SecurityScheme = SecurityScheme
685755 , _securitySchemeDescription :: Maybe Text
686756 } deriving (Eq, Show, Generic, Data, Typeable)
687757
758+
759+-- | merge scopes of two OAuth2 security schemes when their flows are identical.
760+-- In other case returns first security scheme
761+mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme
762+mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc)
763+ s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _)
764+ = if flow1 == flow2 then
765+ SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc
766+ else
767+ s1
768+mergeSecurityScheme s1 _ = s1
769+
770+newtype SecurityDefinitions
771+ = SecurityDefinitions (Definitions SecurityScheme)
772+ deriving (Eq, Show, Generic, Data, Typeable)
773+
688774-- | Lists the required security schemes to execute this operation.
689775-- The object can have multiple security schemes declared in it which are all required
690776-- (that is, there is a logical AND between the schemes).
691777newtype SecurityRequirement = SecurityRequirement
692− { getSecurityRequirement :: HashMap Text [Text]
693− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
778+ { getSecurityRequirement :: InsOrdHashMap Text [Text]
779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
780+
781+-- | Tag name.
782+type TagName = Text
694783
695784-- | Allows adding meta data to a single tag that is used by @Operation@.
696785-- It is not mandatory to have a @Tag@ per tag used there.
697786data Tag = Tag
698787 { -- | The name of the tag.
699− _tagName :: Text
788+ _tagName :: TagName
700789
701790 -- | A short description for the tag.
702791 -- GFM syntax can be used for rich text representation.
@@ -704,7 +793,12 @@ data Tag = Tag
704793
705794 -- | Additional external documentation for this tag.
706795 , _tagExternalDocs :: Maybe ExternalDocs
707− } deriving (Eq, Show, Generic, Data, Typeable)
796+ } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797+
798+instance Hashable Tag
799+
800+instance IsString Tag where
801+ fromString s = Tag (fromString s) Nothing Nothing
708802
709803-- | Allows referencing an external resource for extended documentation.
710804data ExternalDocs = ExternalDocs
@@ -714,7 +808,9 @@ data ExternalDocs = ExternalDocs
714808
715809 -- | The URL for the target documentation.
716810 , _externalDocsUrl :: URL
717− } deriving (Eq, Show, Generic, Data, Typeable)
811+ } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812+
813+instance Hashable ExternalDocs
718814
719815-- | A simple object to allow referencing other definitions in the specification.
720816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
@@ -724,77 +820,133 @@ newtype Reference = Reference { getReference :: Text }
724820data Referenced a
725821 = Ref Reference
726822 | Inline a
727− deriving (Eq, Show, Data, Typeable)
823+ deriving (Eq, Show, Functor, Data, Typeable)
824+
825+instance IsString a => IsString (Referenced a) where
826+ fromString = Inline . fromString
728827
729−newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)
828+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
829+
830+data AdditionalProperties
831+ = AdditionalPropertiesAllowed Bool
832+ | AdditionalPropertiesSchema (Referenced Schema)
833+ deriving (Eq, Show, Data, Typeable)
730834
731835-- =======================================================================
732836-- Monoid instances
733837-- =======================================================================
734838
839+instance Semigroup Swagger where
840+ (<>) = genericMappend
735841instance Monoid Swagger where
736842 mempty = genericMempty
737− mappend = genericMappend
843+ mappend = (<>)
738844
845+instance Semigroup Info where
846+ (<>) = genericMappend
739847instance Monoid Info where
740848 mempty = genericMempty
741− mappend = genericMappend
849+ mappend = (<>)
742850
743−instance Monoid Paths where
851+instance Semigroup Contact where
852+ (<>) = genericMappend
853+instance Monoid Contact where
744854 mempty = genericMempty
745− mappend = genericMappend
855+ mappend = (<>)
746856
857+instance Semigroup PathItem where
858+ (<>) = genericMappend
747859instance Monoid PathItem where
748860 mempty = genericMempty
749− mappend = genericMappend
861+ mappend = (<>)
750862
863+instance Semigroup Schema where
864+ (<>) = genericMappend
751865instance Monoid Schema where
752866 mempty = genericMempty
753− mappend = genericMappend
867+ mappend = (<>)
754868
755−instance Monoid (ParamSchema t i) where
869+instance Semigroup (ParamSchema t) where
870+ (<>) = genericMappend
871+instance Monoid (ParamSchema t) where
756872 mempty = genericMempty
757− mappend = genericMappend
873+ mappend = (<>)
758874
875+instance Semigroup Param where
876+ (<>) = genericMappend
759877instance Monoid Param where
760878 mempty = genericMempty
761− mappend = genericMappend
879+ mappend = (<>)
762880
881+instance Semigroup ParamOtherSchema where
882+ (<>) = genericMappend
763883instance Monoid ParamOtherSchema where
764884 mempty = genericMempty
765− mappend = genericMappend
885+ mappend = (<>)
766886
887+instance Semigroup Header where
888+ (<>) = genericMappend
889+instance Monoid Header where
890+ mempty = genericMempty
891+ mappend = (<>)
892+
893+instance Semigroup Responses where
894+ (<>) = genericMappend
767895instance Monoid Responses where
768896 mempty = genericMempty
769− mappend = genericMappend
897+ mappend = (<>)
770898
899+instance Semigroup Response where
900+ (<>) = genericMappend
771901instance Monoid Response where
772902 mempty = genericMempty
773− mappend = genericMappend
903+ mappend = (<>)
774904
905+instance Semigroup ExternalDocs where
906+ (<>) = genericMappend
775907instance Monoid ExternalDocs where
776908 mempty = genericMempty
777− mappend = genericMappend
909+ mappend = (<>)
778910
911+instance Semigroup Operation where
912+ (<>) = genericMappend
779913instance Monoid Operation where
780914 mempty = genericMempty
781− mappend = genericMappend
915+ mappend = (<>)
916+
917+instance Semigroup Example where
918+ (<>) = genericMappend
919+instance Monoid Example where
920+ mempty = genericMempty
921+ mappend = (<>)
922+
923+instance Semigroup SecurityScheme where
924+ (<>) = mergeSecurityScheme
925+
926+instance Semigroup SecurityDefinitions where
927+ (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928+ SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929+
930+instance Monoid SecurityDefinitions where
931+ mempty = SecurityDefinitions $ InsOrdHashMap.empty
932+ mappend = (<>)
782933
783934-- =======================================================================
784935-- SwaggerMonoid helper instances
785936-- =======================================================================
786937
787938instance SwaggerMonoid Info
788−instance SwaggerMonoid Paths
789939instance SwaggerMonoid PathItem
790940instance SwaggerMonoid Schema
791−instance SwaggerMonoid (ParamSchema t i)
941+instance SwaggerMonoid (ParamSchema t)
792942instance SwaggerMonoid Param
793943instance SwaggerMonoid ParamOtherSchema
794944instance SwaggerMonoid Responses
795945instance SwaggerMonoid Response
796946instance SwaggerMonoid ExternalDocs
797947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
798950
799951instance SwaggerMonoid MimeList
800952deriving instance SwaggerMonoid URL
@@ -807,64 +959,85 @@ instance SwaggerMonoid ParamLocation where
807959 swaggerMempty = ParamQuery
808960 swaggerMappend _ y = y
809961
810−instance SwaggerMonoid (HashMap Text Schema) where
811− swaggerMempty = HashMap.empty
812− swaggerMappend = HashMap.unionWith mappend
813−
814−instance SwaggerMonoid (HashMap Text (Referenced Schema)) where
815− swaggerMempty = HashMap.empty
816− swaggerMappend = HashMap.unionWith swaggerMappend
962+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963+ swaggerMempty = InsOrdHashMap.empty
964+ swaggerMappend = InsOrdHashMap.unionWith mappend
817965
818966instance Monoid a => SwaggerMonoid (Referenced a) where
819967 swaggerMempty = Inline mempty
820− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
821969 swaggerMappend _ y = y
822970
823−instance SwaggerMonoid (HashMap Text Param) where
824− swaggerMempty = HashMap.empty
825− swaggerMappend = HashMap.unionWith mappend
971+instance SwaggerMonoid ParamAnySchema where
972+ swaggerMempty = ParamOther swaggerMempty
973+ swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
974+ swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
975+ swaggerMappend _ y = y
826976
827−instance SwaggerMonoid (HashMap Text Response) where
828− swaggerMempty = HashMap.empty
829− swaggerMappend = flip HashMap.union
977+-- =======================================================================
978+-- Simple Generic-based ToJSON instances
979+-- =======================================================================
830980
831−instance SwaggerMonoid (HashMap Text SecurityScheme) where
832− swaggerMempty = HashMap.empty
833− swaggerMappend = flip HashMap.union
981+instance ToJSON ParamLocation where
982+ toJSON = genericToJSON (jsonPrefix "Param")
834983
835−instance SwaggerMonoid (HashMap FilePath PathItem) where
836− swaggerMempty = HashMap.empty
837− swaggerMappend = HashMap.unionWith mappend
984+instance ToJSON Info where
985+ toJSON = genericToJSON (jsonPrefix "Info")
838986
839−instance SwaggerMonoid (HashMap HeaderName Header) where
840− swaggerMempty = HashMap.empty
841− swaggerMappend = flip HashMap.union
987+instance ToJSON Contact where
988+ toJSON = genericToJSON (jsonPrefix "Contact")
842989
843−instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
844− swaggerMempty = HashMap.empty
845− swaggerMappend = flip HashMap.union
990+instance ToJSON License where
991+ toJSON = genericToJSON (jsonPrefix "License")
846992
847−instance SwaggerMonoid ParamAnySchema where
848− swaggerMempty = ParamOther swaggerMempty
849− swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
850− swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
851− swaggerMappend _ y = y
993+instance ToJSON ApiKeyLocation where
994+ toJSON = genericToJSON (jsonPrefix "ApiKey")
995+
996+instance ToJSON ApiKeyParams where
997+ toJSON = genericToJSON (jsonPrefix "apiKey")
998+
999+instance ToJSON Scheme where
1000+ toJSON = genericToJSON (jsonPrefix "")
1001+
1002+instance ToJSON Tag where
1003+ toJSON = genericToJSON (jsonPrefix "Tag")
1004+
1005+instance ToJSON ExternalDocs where
1006+ toJSON = genericToJSON (jsonPrefix "ExternalDocs")
1007+
1008+instance ToJSON Xml where
1009+ toJSON = genericToJSON (jsonPrefix "Xml")
8521010
8531011-- =======================================================================
854−-- TH derived ToJSON and FromJSON instances
1012+-- Simple Generic-based FromJSON instances
8551013-- =======================================================================
8561014
857−deriveJSON (jsonPrefix "Param") ''ParamLocation
858−deriveJSON' ''Info
859−deriveJSON' ''Contact
860−deriveJSON' ''License
861−deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
862−deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
863−deriveJSONDefault ''Scheme
864−deriveJSON' ''Tag
865−deriveJSON' ''ExternalDocs
1015+instance FromJSON ParamLocation where
1016+ parseJSON = genericParseJSON (jsonPrefix "Param")
1017+
1018+instance FromJSON Info where
1019+ parseJSON = genericParseJSON (jsonPrefix "Info")
8661020
867−deriveToJSON' ''Xml
1021+instance FromJSON Contact where
1022+ parseJSON = genericParseJSON (jsonPrefix "Contact")
1023+
1024+instance FromJSON License where
1025+ parseJSON = genericParseJSON (jsonPrefix "License")
1026+
1027+instance FromJSON ApiKeyLocation where
1028+ parseJSON = genericParseJSON (jsonPrefix "ApiKey")
1029+
1030+instance FromJSON ApiKeyParams where
1031+ parseJSON = genericParseJSON (jsonPrefix "apiKey")
1032+
1033+instance FromJSON Scheme where
1034+ parseJSON = genericParseJSON (jsonPrefix "")
1035+
1036+instance FromJSON Tag where
1037+ parseJSON = genericParseJSON (jsonPrefix "Tag")
1038+
1039+instance FromJSON ExternalDocs where
1040+ parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
8681041
8691042-- =======================================================================
8701043-- Manual ToJSON instances
@@ -886,7 +1059,8 @@ instance ToJSON OAuth2Flow where
8861059 , "tokenUrl" .= tokenUrl ]
8871060
8881061instance ToJSON OAuth2Params where
889− toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1062+ toJSON = sopSwaggerGenericToJSON
1063+ DEFINE_TOENCODING
8901064
8911065instance ToJSON SecuritySchemeType where
8921066 toJSON SecuritySchemeBasic
@@ -899,22 +1073,38 @@ instance ToJSON SecuritySchemeType where
8991073 <+> object [ "type" .= ("oauth2" :: Text) ]
9001074
9011075instance ToJSON Swagger where
902− toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "")
903− where
904− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
905− addVersion _ = error "impossible"
1076+ toJSON = sopSwaggerGenericToJSON
1077+ DEFINE_TOENCODING
9061078
9071079instance ToJSON SecurityScheme where
908− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1080+ toJSON = sopSwaggerGenericToJSON
1081+ DEFINE_TOENCODING
9091082
9101083instance ToJSON Schema where
911− toJSON = omitEmpties . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
1084+ toJSON = sopSwaggerGenericToJSON
1085+ DEFINE_TOENCODING
9121086
9131087instance ToJSON Header where
914− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
915−
916−instance ToJSON Items where
917− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items")
1088+ toJSON = sopSwaggerGenericToJSON
1089+ DEFINE_TOENCODING
1090+
1091+-- | As for nullary schema for 0-arity type constructors, see
1092+-- <https://github.com/GetShopTV/swagger2/issues/167>.
1093+--
1094+-- >>> encode (SwaggerItemsArray [])
1095+-- "{\"example\":[],\"items\":{},\"maxItems\":0}"
1096+--
1097+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
1098+ toJSON (SwaggerItemsPrimitive fmt schema) = object
1099+ [ "collectionFormat" .= fmt
1100+ , "items" .= schema ]
1101+ toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102+ toJSON (SwaggerItemsArray []) = object
1103+ [ "items" .= object []
1104+ , "maxItems" .= (0 :: Int)
1105+ , "example" .= Array mempty
1106+ ]
1107+ toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
9181108
9191109instance ToJSON Host where
9201110 toJSON (Host host mport) = toJSON $
@@ -922,42 +1112,43 @@ instance ToJSON Host where
9221112 Nothing -> host
9231113 Just port -> host ++ ":" ++ show port
9241114
925−instance ToJSON Paths where
926− toJSON (Paths m) = toJSON m
927−
9281115instance ToJSON MimeList where
9291116 toJSON (MimeList xs) = toJSON (map show xs)
9301117
9311118instance ToJSON Param where
932− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1119+ toJSON = sopSwaggerGenericToJSON
1120+ DEFINE_TOENCODING
9331121
9341122instance ToJSON ParamAnySchema where
9351123 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
9361124 toJSON (ParamOther s) = toJSON s
9371125
9381126instance ToJSON ParamOtherSchema where
939− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
940−
941−instance ToJSON SchemaItems where
942− toJSON (SchemaItemsObject x) = toJSON x
943− toJSON (SchemaItemsArray xs) = toJSON xs
1127+ toJSON = sopSwaggerGenericToJSON
1128+ DEFINE_TOENCODING
9441129
9451130instance ToJSON Responses where
946− toJSON (Responses def rs) = omitEmpties $
947− toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1131+ toJSON = sopSwaggerGenericToJSON
1132+ DEFINE_TOENCODING
9481133
9491134instance ToJSON Response where
950− toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
1135+ toJSON = sopSwaggerGenericToJSON
1136+ DEFINE_TOENCODING
9511137
9521138instance ToJSON Operation where
953− toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
1139+ toJSON = sopSwaggerGenericToJSON
1140+ DEFINE_TOENCODING
9541141
9551142instance ToJSON PathItem where
956− toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1143+ toJSON = sopSwaggerGenericToJSON
1144+ DEFINE_TOENCODING
9571145
9581146instance ToJSON Example where
9591147 toJSON = toJSON . Map.mapKeys show . getExample
9601148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
9611152instance ToJSON Reference where
9621153 toJSON (Reference ref) = object [ "$ref" .= ref ]
9631154
@@ -986,8 +1177,14 @@ instance ToJSON (CollectionFormat t) where
9861177 toJSON CollectionPipes = "pipes"
9871178 toJSON CollectionMulti = "multi"
9881179
989−instance ToJSON i => ToJSON (ParamSchema t i) where
990− toJSON = genericToJSON (jsonPrefix "paramSchema")
1180+instance ToJSON (ParamSchema k) where
1181+ -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1182+ toJSON = sopSwaggerGenericToJSONWithOpts $
1183+ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1184+
1185+instance ToJSON AdditionalProperties where
1186+ toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187+ toJSON (AdditionalPropertiesSchema s) = toJSON s
9911188
9921189-- =======================================================================
9931190-- Manual FromJSON instances
@@ -1007,7 +1204,7 @@ instance FromJSON OAuth2Flow where
10071204 parseJSON _ = empty
10081205
10091206instance FromJSON OAuth2Params where
1010− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1207+ parseJSON = sopSwaggerGenericParseJSON
10111208
10121209instance FromJSON SecuritySchemeType where
10131210 parseJSON js@(Object o) = do
@@ -1020,53 +1217,65 @@ instance FromJSON SecuritySchemeType where
10201217 parseJSON _ = empty
10211218
10221219instance FromJSON Swagger where
1023− parseJSON js@(Object o) = do
1024− (version :: Text) <- o .: "swagger"
1025− when (version /= "2.0") empty
1026− (genericParseJSON (jsonPrefix "")
1027− `withDefaults` [ "consumes" .= (mempty :: MimeList)
1028− , "produces" .= (mempty :: MimeList)
1029− , "security" .= ([] :: [SecurityRequirement])
1030− , "tags" .= ([] :: [Tag])
1031− , "definitions" .= (mempty :: HashMap Text Schema)
1032− , "parameters" .= (mempty :: HashMap Text Param)
1033− , "responses" .= (mempty :: HashMap Text Response)
1034− , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
1035− ] ) js
1036− parseJSON _ = empty
1220+ parseJSON = sopSwaggerGenericParseJSON
10371221
10381222instance FromJSON SecurityScheme where
1039− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1223+ parseJSON = sopSwaggerGenericParseJSON
10401224
10411225instance FromJSON Schema where
1042− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1043− `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1044− , "required" .= ([] :: [ParamName]) ]
1226+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1227+ where nullaryCleanup :: Schema -> Schema
1228+ nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229+ if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230+ then s { _schemaExample = Nothing
1231+ , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232+ else s
10451233
10461234instance FromJSON Header where
1047− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1048−
1049−instance FromJSON Items where
1050− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items")
1235+ parseJSON = sopSwaggerGenericParseJSON
1236+
1237+instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1238+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1239+ <$> o .:? "collectionFormat"
1240+ <*> (o .: "items" >>= parseJSON)
1241+
1242+instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1243+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1244+ <$> o .:? "collectionFormat"
1245+ <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1246+
1247+-- |
1248+--
1249+-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)
1250+-- Just (SwaggerItemsArray [])
1251+--
1252+-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)
1253+-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))
1254+--
1255+-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)
1256+-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])
1257+--
1258+instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1259+ parseJSON js@(Object obj)
1260+ | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261+ | otherwise = SwaggerItemsObject <$> parseJSON js
1262+ parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1263+ parseJSON _ = empty
10511264
10521265instance FromJSON Host where
1053− parseJSON (String s) =
1054− case fromInteger <$> readMaybe portStr of
1055− Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1056− mport -> pure $ Host host mport
1057− where
1058− (hostText, portText) = Text.breakOn ":" s
1059− [host, portStr] = map Text.unpack [hostText, portText]
1266+ parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
1267+ [host] -> return $ Host host Nothing
1268+ [host, port] -> case readMaybe port of
1269+ Nothing -> fail $ "Invalid port `" ++ port ++ "'"
1270+ Just p -> return $ Host host (Just (fromInteger p))
1271+ _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
10601272 parseJSON _ = empty
10611273
1062−instance FromJSON Paths where
1063− parseJSON js = Paths <$> parseJSON js
1064−
10651274instance FromJSON MimeList where
10661275 parseJSON js = (MimeList . map fromString) <$> parseJSON js
10671276
10681277instance FromJSON Param where
1069− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1278+ parseJSON = sopSwaggerGenericParseJSON
10701279
10711280instance FromJSON ParamAnySchema where
10721281 parseJSON js@(Object o) = do
@@ -1079,17 +1288,12 @@ instance FromJSON ParamAnySchema where
10791288 parseJSON _ = empty
10801289
10811290instance FromJSON ParamOtherSchema where
1082− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1083−
1084−instance FromJSON SchemaItems where
1085− parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js
1086− parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js
1087− parseJSON _ = empty
1291+ parseJSON = sopSwaggerGenericParseJSON
10881292
10891293instance FromJSON Responses where
10901294 parseJSON (Object o) = Responses
10911295 <$> o .:? "default"
1092− <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1296+ <*> (parseJSON (Object (HashMap.delete "default" o)))
10931297 parseJSON _ = empty
10941298
10951299instance FromJSON Example where
@@ -1098,16 +1302,16 @@ instance FromJSON Example where
10981302 pure $ Example (Map.mapKeys fromString m)
10991303
11001304instance FromJSON Response where
1101− parseJSON = genericParseJSON (jsonPrefix "response")
1102− `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1305+ parseJSON = sopSwaggerGenericParseJSON
11031306
11041307instance FromJSON Operation where
1105− parseJSON = genericParseJSON (jsonPrefix "operation")
1106− `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1308+ parseJSON = sopSwaggerGenericParseJSON
11071309
11081310instance FromJSON PathItem where
1109− parseJSON = genericParseJSON (jsonPrefix "pathItem")
1110− `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1311+ parseJSON = sopSwaggerGenericParseJSON
1312+
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
11111315
11121316instance FromJSON Reference where
11131317 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1124,6 +1328,7 @@ referencedParseJSON prefix js@(Object o) = do
11241328 case Text.stripPrefix prefix s of
11251329 Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
11261330 Just suffix -> pure (Reference suffix)
1331+referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
11271332
11281333instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
11291334instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
@@ -1132,23 +1337,91 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
11321337instance FromJSON Xml where
11331338 parseJSON = genericParseJSON (jsonPrefix "xml")
11341339
1135−instance FromJSON (SwaggerType Schema) where
1340+instance FromJSON (SwaggerType 'SwaggerKindSchema) where
11361341 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
11371342
1138−instance FromJSON (SwaggerType ParamOtherSchema) where
1343+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
11391344 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
11401345
1141−instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
1346+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
11421347 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
11431348
1144−instance FromJSON (CollectionFormat Param) where
1145− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1146−
1147−instance FromJSON (CollectionFormat Items) where
1349+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
11481350 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
11491351
1150−-- NOTE: The constraint @FromJSON (SwaggerType t)@ is necessary here!
1151−-- Without the constraint the general instance will be used
1152−-- that only accepts common types (i.e. NOT object, null or file).
1153−instance (FromJSON (SwaggerType t), FromJSON i) => FromJSON (ParamSchema t i) where
1154− parseJSON = genericParseJSON (jsonPrefix "ParamSchema")
1352+-- NOTE: There aren't collections of 'Schema'
1353+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1354+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355+
1356+instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1357+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1358+
1359+instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1360+ parseJSON = sopSwaggerGenericParseJSON
1361+instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1362+ parseJSON = sopSwaggerGenericParseJSON
1363+instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1364+ parseJSON = sopSwaggerGenericParseJSON
1365+
1366+instance FromJSON AdditionalProperties where
1367+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369+
1370+-------------------------------------------------------------------------------
1371+-- TH splices
1372+-------------------------------------------------------------------------------
1373+
1374+deriveGeneric ''Header
1375+deriveGeneric ''OAuth2Params
1376+deriveGeneric ''Operation
1377+deriveGeneric ''Param
1378+deriveGeneric ''ParamOtherSchema
1379+deriveGeneric ''PathItem
1380+deriveGeneric ''Response
1381+deriveGeneric ''Responses
1382+deriveGeneric ''SecurityScheme
1383+deriveGeneric ''Schema
1384+deriveGeneric ''ParamSchema
1385+deriveGeneric ''Swagger
1386+
1387+instance HasSwaggerAesonOptions Header where
1388+ swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1389+instance HasSwaggerAesonOptions OAuth2Params where
1390+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1391+instance HasSwaggerAesonOptions Operation where
1392+ swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1393+instance HasSwaggerAesonOptions Param where
1394+ swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1395+instance HasSwaggerAesonOptions ParamOtherSchema where
1396+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1397+instance HasSwaggerAesonOptions PathItem where
1398+ swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1399+instance HasSwaggerAesonOptions Response where
1400+ swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1401+instance HasSwaggerAesonOptions Responses where
1402+ swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1403+instance HasSwaggerAesonOptions SecurityScheme where
1404+ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1405+instance HasSwaggerAesonOptions Schema where
1406+ swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1407+instance HasSwaggerAesonOptions Swagger where
1408+ swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1409+
1410+instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where
1411+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1412+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where
1413+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1414+-- NOTE: Schema doesn't have 'items' sub object!
1415+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where
1416+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1417+
1418+instance AesonDefaultValue (ParamSchema s)
1419+instance AesonDefaultValue OAuth2Flow
1420+instance AesonDefaultValue Responses
1421+instance AesonDefaultValue ParamAnySchema
1422+instance AesonDefaultValue SecuritySchemeType
1423+instance AesonDefaultValue (SwaggerType a)
1424+instance AesonDefaultValue MimeList where defaultValue = Just mempty
1425+instance AesonDefaultValue Info
1426+instance AesonDefaultValue ParamLocation
1427+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty