@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE DeriveDataTypeable #-}
34{-# LANGUAGE DeriveFunctor #-}
45{-# LANGUAGE DeriveGeneric #-}
@@ -11,11 +12,12 @@
1112{-# LANGUAGE RecordWildCards #-}
1213{-# LANGUAGE ScopedTypeVariables #-}
1314{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−
16−{-# LANGUAGE DataKinds #-}
17−{-# LANGUAGE TypeFamilies #-}
1815{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ <710
19+{-# LANGUAGE PolyKinds #-}
20+#endif
1921#include "overlapping-compat.h"
2022module Data.Swagger.Internal where
2123
@@ -24,22 +26,22 @@ import Prelude.Compat
2426
2527import Control.Lens ((&), (.~), (?~))
2628import Control.Applicative
27−import Control.Monad
2829import Data.Aeson
2930import qualified Data.Aeson.Types as JSON
3031import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
31−import Data.HashMap.Strict (HashMap)
32+import Data.Hashable (Hashable)
3233import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
3335import Data.Map (Map)
3436import qualified Data.Map as Map
35−import Data.Monoid
37+import Data.Monoid (Monoid (..))
38+import Data.Semigroup.Compat (Semigroup (..))
3639import Data.Scientific (Scientific)
37−import Data.Set (Set)
3840import Data.String (IsString(..))
3941import Data.Text (Text)
4042import qualified Data.Text as Text
4143import GHC.Generics (Generic)
42−import Network (HostName, PortNumber)
44+import Network.Socket (HostName, PortNumber)
4345import Network.HTTP.Media (MediaType)
4446import Text.Read (readMaybe)
4547
@@ -48,11 +50,26 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4850
4951import Generics.SOP.TH (deriveGeneric)
5052import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
53+ ,sopSwaggerGenericToJSONWithOpts
54+ ,sopSwaggerGenericParseJSON
55+ ,HasSwaggerAesonOptions(..)
56+ ,AesonDefaultValue(..)
5157 ,mkSwaggerAesonOptions
5258 ,saoAdditionalPairs
5359 ,saoSubObject)
5460import Data.Swagger.Internal.Utils
5561
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+
5673-- | A list of definitions that can be used in references.
5774type Definitions = InsOrdHashMap Text
5875
@@ -100,7 +117,7 @@ data Swagger = Swagger
100117 , _swaggerResponses :: Definitions Response
101118
102119 -- | Security scheme definitions that can be used across the specification.
103− , _swaggerSecurityDefinitions :: Definitions SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
104121
105122 -- | A declaration of which security schemes are applied for the API as a whole.
106123 -- The list of values describes alternative security schemes that can be used
@@ -113,7 +130,7 @@ data Swagger = Swagger
113130 -- Not all tags that are used by the Operation Object must be declared.
114131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
115132 -- Each tag name in the list MUST be unique.
116− , _swaggerTags :: Set Tag
133+ , _swaggerTags :: InsOrdHashSet Tag
117134
118135 -- | Additional external documentation.
119136 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -235,7 +252,7 @@ data PathItem = PathItem
235252data Operation = Operation
236253 { -- | A list of tags for API documentation control.
237254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
238− _operationTags :: Set TagName
255+ _operationTags :: InsOrdHashSet TagName
239256
240257 -- | A short summary of what the operation does.
241258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -292,7 +309,7 @@ data Operation = Operation
292309 } deriving (Eq, Show, Generic, Data, Typeable)
293310
294311newtype MimeList = MimeList { getMimeList :: [MediaType] }
295− deriving (Eq, Show, Monoid, Typeable)
312+ deriving (Eq, Show, Semigroup, Monoid, Typeable)
296313
297314mimeListConstr :: Constr
298315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -343,8 +360,8 @@ data ParamOtherSchema = ParamOtherSchema
343360 -- Default value is @False@.
344361 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
345362
346− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
347− } deriving (Eq, Show, Generic, Data, Typeable)
363+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364+ } deriving (Eq, Show, Generic, Typeable, Data)
348365
349366-- | Items for @'SwaggerArray'@ schemas.
350367--
@@ -357,9 +374,9 @@ data ParamOtherSchema = ParamOtherSchema
357374--
358375-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
359376data SwaggerItems t where
360− SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
361− SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
362− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
377+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
363380 deriving (Typeable)
364381
365382deriving instance Eq (SwaggerItems t)
@@ -369,17 +386,66 @@ deriving instance Show (SwaggerItems t)
369386swaggerItemsPrimitiveConstr :: Constr
370387swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
371388
389+swaggerItemsObjectConstr :: Constr
390+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391+
392+swaggerItemsArrayConstr :: Constr
393+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394+
372395swaggerItemsDataType :: DataType
373396swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
374397
375−instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
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
376403 gunfold k z c = case constrIndex c of
377404 1 -> k (k (z SwaggerItemsPrimitive))
378405 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
379406 toConstr _ = swaggerItemsPrimitiveConstr
380407 dataTypeOf _ = swaggerItemsDataType
381408
382−deriving instance Data (SwaggerItems Schema)
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
417+
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
383449
384450data SwaggerType t where
385451 SwaggerString :: SwaggerType t
@@ -387,9 +453,9 @@ data SwaggerType t where
387453 SwaggerInteger :: SwaggerType t
388454 SwaggerBoolean :: SwaggerType t
389455 SwaggerArray :: SwaggerType t
390− SwaggerFile :: SwaggerType ParamOtherSchema
391− SwaggerNull :: SwaggerType Schema
392− SwaggerObject :: SwaggerType Schema
456+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457+ SwaggerNull :: SwaggerType 'SwaggerKindSchema
458+ SwaggerObject :: SwaggerType 'SwaggerKindSchema
393459 deriving (Typeable)
394460
395461deriving instance Eq (SwaggerType t)
@@ -398,33 +464,33 @@ deriving instance Show (SwaggerType t)
398464swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
399465swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
400466
401−swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
467+swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
402468swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
403469
404−swaggerCommonTypes :: [SwaggerType t]
470+swaggerCommonTypes :: [SwaggerType k]
405471swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
406472
407−swaggerParamTypes :: [SwaggerType ParamOtherSchema]
473+swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
408474swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
409475
410−swaggerSchemaTypes :: [SwaggerType Schema]
476+swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
411477swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
412478
413479swaggerTypeConstrs :: [Constr]
414−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
480+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
415481 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
416482
417−instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
483+instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
418484 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
419485 toConstr = swaggerTypeConstr
420486 dataTypeOf = swaggerTypeDataType
421487
422−instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
488+instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
423489 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
424490 toConstr = swaggerTypeConstr
425491 dataTypeOf = swaggerTypeDataType
426492
427−instance OVERLAPPABLE_ Data (SwaggerType Schema) where
493+instance Data (SwaggerType 'SwaggerKindSchema) where
428494 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
429495 toConstr = swaggerTypeConstr
430496 dataTypeOf = swaggerTypeDataType
@@ -464,7 +530,7 @@ data CollectionFormat t where
464530 -- Corresponds to multiple parameter instances
465531 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
466532 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
467− CollectionMulti :: CollectionFormat ParamOtherSchema
533+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
468534 deriving (Typeable)
469535
470536deriving instance Eq (CollectionFormat t)
@@ -480,12 +546,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
480546collectionCommonFormats :: [CollectionFormat t]
481547collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
482548
483−instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
549+instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
484550 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
485551 toConstr = collectionFormatConstr
486552 dataTypeOf _ = collectionFormatDataType
487553
488−deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
554+deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
489555
490556type ParamName = Text
491557
@@ -494,9 +560,9 @@ data Schema = Schema
494560 , _schemaDescription :: Maybe Text
495561 , _schemaRequired :: [ParamName]
496562
497− , _schemaAllOf :: Maybe [Schema]
563+ , _schemaAllOf :: Maybe [Referenced Schema]
498564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
499− , _schemaAdditionalProperties :: Maybe (Referenced Schema)
565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
500566
501567 , _schemaDiscriminator :: Maybe Text
502568 , _schemaReadOnly :: Maybe Bool
@@ -507,7 +573,7 @@ data Schema = Schema
507573 , _schemaMaxProperties :: Maybe Integer
508574 , _schemaMinProperties :: Maybe Integer
509575
510− , _schemaParamSchema :: ParamSchema Schema
576+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
511577 } deriving (Eq, Show, Generic, Data, Typeable)
512578
513579-- | A @'Schema'@ with an optional name.
@@ -520,7 +586,7 @@ data NamedSchema = NamedSchema
520586-- | Regex pattern for @string@ type.
521587type Pattern = Text
522588
523−data ParamSchema t = ParamSchema
589+data ParamSchema (t :: SwaggerKind *) = ParamSchema
524590 { -- | Declares the value of the parameter that the server will use if none is provided,
525591 -- for example a @"count"@ to control the number of results per page might default to @100@
526592 -- if not supplied by the client in the request.
@@ -528,7 +594,7 @@ data ParamSchema t = ParamSchema
528594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
529595 _paramSchemaDefault :: Maybe Value
530596
531− , _paramSchemaType :: SwaggerType t
597+ , _paramSchemaType :: Maybe (SwaggerType t)
532598 , _paramSchemaFormat :: Maybe Format
533599 , _paramSchemaItems :: Maybe (SwaggerItems t)
534600 , _paramSchemaMaximum :: Maybe Scientific
@@ -545,7 +611,7 @@ data ParamSchema t = ParamSchema
545611 , _paramSchemaMultipleOf :: Maybe Scientific
546612 } deriving (Eq, Show, Generic, Typeable)
547613
548−deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
614+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
549615
550616data Xml = Xml
551617 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -621,7 +687,7 @@ data Header = Header
621687 { -- | A short description of the header.
622688 _headerDescription :: Maybe Text
623689
624− , _headerParamSchema :: ParamSchema Header
690+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
625691 } deriving (Eq, Show, Generic, Data, Typeable)
626692
627693data Example = Example { getExample :: Map MediaType Value }
@@ -689,12 +755,28 @@ data SecurityScheme = SecurityScheme
689755 , _securitySchemeDescription :: Maybe Text
690756 } deriving (Eq, Show, Generic, Data, Typeable)
691757
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+
692774-- | Lists the required security schemes to execute this operation.
693775-- The object can have multiple security schemes declared in it which are all required
694776-- (that is, there is a logical AND between the schemes).
695777newtype SecurityRequirement = SecurityRequirement
696778 { getSecurityRequirement :: InsOrdHashMap Text [Text]
697− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
698780
699781-- | Tag name.
700782type TagName = Text
@@ -713,6 +795,8 @@ data Tag = Tag
713795 , _tagExternalDocs :: Maybe ExternalDocs
714796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
715797
798+instance Hashable Tag
799+
716800instance IsString Tag where
717801 fromString s = Tag (fromString s) Nothing Nothing
718802
@@ -726,6 +810,8 @@ data ExternalDocs = ExternalDocs
726810 , _externalDocsUrl :: URL
727811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
728812
813+instance Hashable ExternalDocs
814+
729815-- | A simple object to allow referencing other definitions in the specification.
730816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
731817newtype Reference = Reference { getReference :: Text }
@@ -739,67 +825,111 @@ data Referenced a
739825instance IsString a => IsString (Referenced a) where
740826 fromString = Inline . fromString
741827
742−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, 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)
743834
744835-- =======================================================================
745836-- Monoid instances
746837-- =======================================================================
747838
839+instance Semigroup Swagger where
840+ (<>) = genericMappend
748841instance Monoid Swagger where
749842 mempty = genericMempty
750− mappend = genericMappend
843+ mappend = (<>)
751844
845+instance Semigroup Info where
846+ (<>) = genericMappend
752847instance Monoid Info where
753848 mempty = genericMempty
754− mappend = genericMappend
849+ mappend = (<>)
755850
851+instance Semigroup Contact where
852+ (<>) = genericMappend
756853instance Monoid Contact where
757854 mempty = genericMempty
758− mappend = genericMappend
855+ mappend = (<>)
759856
857+instance Semigroup PathItem where
858+ (<>) = genericMappend
760859instance Monoid PathItem where
761860 mempty = genericMempty
762− mappend = genericMappend
861+ mappend = (<>)
763862
863+instance Semigroup Schema where
864+ (<>) = genericMappend
764865instance Monoid Schema where
765866 mempty = genericMempty
766− mappend = genericMappend
867+ mappend = (<>)
767868
869+instance Semigroup (ParamSchema t) where
870+ (<>) = genericMappend
768871instance Monoid (ParamSchema t) where
769872 mempty = genericMempty
770− mappend = genericMappend
873+ mappend = (<>)
771874
875+instance Semigroup Param where
876+ (<>) = genericMappend
772877instance Monoid Param where
773878 mempty = genericMempty
774− mappend = genericMappend
879+ mappend = (<>)
775880
881+instance Semigroup ParamOtherSchema where
882+ (<>) = genericMappend
776883instance Monoid ParamOtherSchema where
777884 mempty = genericMempty
778− mappend = genericMappend
885+ mappend = (<>)
779886
887+instance Semigroup Header where
888+ (<>) = genericMappend
780889instance Monoid Header where
781890 mempty = genericMempty
782− mappend = genericMappend
891+ mappend = (<>)
783892
893+instance Semigroup Responses where
894+ (<>) = genericMappend
784895instance Monoid Responses where
785896 mempty = genericMempty
786− mappend = genericMappend
897+ mappend = (<>)
787898
899+instance Semigroup Response where
900+ (<>) = genericMappend
788901instance Monoid Response where
789902 mempty = genericMempty
790− mappend = genericMappend
903+ mappend = (<>)
791904
905+instance Semigroup ExternalDocs where
906+ (<>) = genericMappend
792907instance Monoid ExternalDocs where
793908 mempty = genericMempty
794− mappend = genericMappend
909+ mappend = (<>)
795910
911+instance Semigroup Operation where
912+ (<>) = genericMappend
796913instance Monoid Operation where
797914 mempty = genericMempty
798− mappend = genericMappend
915+ mappend = (<>)
799916
917+instance Semigroup Example where
918+ (<>) = genericMappend
800919instance Monoid Example where
801920 mempty = genericMempty
802− mappend = genericMappend
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 = (<>)
803933
804934-- =======================================================================
805935-- SwaggerMonoid helper instances
@@ -815,6 +945,8 @@ instance SwaggerMonoid Responses
815945instance SwaggerMonoid Response
816946instance SwaggerMonoid ExternalDocs
817947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
818950
819951instance SwaggerMonoid MimeList
820952deriving instance SwaggerMonoid URL
@@ -827,17 +959,13 @@ instance SwaggerMonoid ParamLocation where
827959 swaggerMempty = ParamQuery
828960 swaggerMappend _ y = y
829961
830−instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
831− swaggerMempty = HashMap.empty
832− swaggerMappend = HashMap.unionWith mappend
833−
834962instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
835963 swaggerMempty = InsOrdHashMap.empty
836964 swaggerMappend = InsOrdHashMap.unionWith mappend
837965
838966instance Monoid a => SwaggerMonoid (Referenced a) where
839967 swaggerMempty = Inline mempty
840− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
841969 swaggerMappend _ y = y
842970
843971instance SwaggerMonoid ParamAnySchema where
@@ -931,8 +1059,8 @@ instance ToJSON OAuth2Flow where
9311059 , "tokenUrl" .= tokenUrl ]
9321060
9331061instance ToJSON OAuth2Params where
934− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" &
935− saoSubObject ?~ "flow"
1062+ toJSON = sopSwaggerGenericToJSON
1063+ DEFINE_TOENCODING
9361064
9371065instance ToJSON SecuritySchemeType where
9381066 toJSON SecuritySchemeBasic
@@ -945,26 +1073,37 @@ instance ToJSON SecuritySchemeType where
9451073 <+> object [ "type" .= ("oauth2" :: Text) ]
9461074
9471075instance ToJSON Swagger where
948− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" &
949− saoAdditionalPairs .~ [("swagger", "2.0")]
1076+ toJSON = sopSwaggerGenericToJSON
1077+ DEFINE_TOENCODING
9501078
9511079instance ToJSON SecurityScheme where
952− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" &
953− saoSubObject ?~ "type"
1080+ toJSON = sopSwaggerGenericToJSON
1081+ DEFINE_TOENCODING
9541082
9551083instance ToJSON Schema where
956− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" &
957− saoSubObject ?~ "paramSchema"
1084+ toJSON = sopSwaggerGenericToJSON
1085+ DEFINE_TOENCODING
9581086
9591087instance ToJSON Header where
960− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" &
961− saoSubObject ?~ "paramSchema"
1088+ toJSON = sopSwaggerGenericToJSON
1089+ DEFINE_TOENCODING
9621090
963−instance ToJSON (SwaggerItems t) where
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
9641098 toJSON (SwaggerItemsPrimitive fmt schema) = object
9651099 [ "collectionFormat" .= fmt
9661100 , "items" .= schema ]
9671101 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102+ toJSON (SwaggerItemsArray []) = object
1103+ [ "items" .= object []
1104+ , "maxItems" .= (0 :: Int)
1105+ , "example" .= Array mempty
1106+ ]
9681107 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
9691108
9701109instance ToJSON Host where
@@ -977,33 +1116,39 @@ instance ToJSON MimeList where
9771116 toJSON (MimeList xs) = toJSON (map show xs)
9781117
9791118instance ToJSON Param where
980− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" &
981− saoSubObject ?~ "schema"
1119+ toJSON = sopSwaggerGenericToJSON
1120+ DEFINE_TOENCODING
9821121
9831122instance ToJSON ParamAnySchema where
9841123 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
9851124 toJSON (ParamOther s) = toJSON s
9861125
9871126instance ToJSON ParamOtherSchema where
988− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" &
989− saoSubObject ?~ "paramSchema"
1127+ toJSON = sopSwaggerGenericToJSON
1128+ DEFINE_TOENCODING
9901129
9911130instance ToJSON Responses where
992− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" &
993− saoSubObject ?~ "responses"
1131+ toJSON = sopSwaggerGenericToJSON
1132+ DEFINE_TOENCODING
9941133
9951134instance ToJSON Response where
996− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response"
1135+ toJSON = sopSwaggerGenericToJSON
1136+ DEFINE_TOENCODING
9971137
9981138instance ToJSON Operation where
999− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation"
1139+ toJSON = sopSwaggerGenericToJSON
1140+ DEFINE_TOENCODING
10001141
10011142instance ToJSON PathItem where
1002− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem"
1143+ toJSON = sopSwaggerGenericToJSON
1144+ DEFINE_TOENCODING
10031145
10041146instance ToJSON Example where
10051147 toJSON = toJSON . Map.mapKeys show . getExample
10061148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
10071152instance ToJSON Reference where
10081153 toJSON (Reference ref) = object [ "$ref" .= ref ]
10091154
@@ -1032,9 +1177,14 @@ instance ToJSON (CollectionFormat t) where
10321177 toJSON CollectionPipes = "pipes"
10331178 toJSON CollectionMulti = "multi"
10341179
1035−instance ToJSON (ParamSchema t) where
1036− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" &
1037− saoSubObject ?~ "items"
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
10381188
10391189-- =======================================================================
10401190-- Manual FromJSON instances
@@ -1054,7 +1204,7 @@ instance FromJSON OAuth2Flow where
10541204 parseJSON _ = empty
10551205
10561206instance FromJSON OAuth2Params where
1057− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1207+ parseJSON = sopSwaggerGenericParseJSON
10581208
10591209instance FromJSON SecuritySchemeType where
10601210 parseJSON js@(Object o) = do
@@ -1067,39 +1217,48 @@ instance FromJSON SecuritySchemeType where
10671217 parseJSON _ = empty
10681218
10691219instance FromJSON Swagger where
1070− parseJSON js@(Object o) = do
1071− (version :: Text) <- o .: "swagger"
1072− when (version /= "2.0") empty
1073− (genericParseJSON (jsonPrefix "swagger")
1074− `withDefaults` [ "consumes" .= (mempty :: MimeList)
1075− , "produces" .= (mempty :: MimeList)
1076− , "security" .= ([] :: [SecurityRequirement])
1077− , "tags" .= ([] :: [Tag])
1078− , "definitions" .= (mempty :: Definitions Schema)
1079− , "parameters" .= (mempty :: Definitions Param)
1080− , "responses" .= (mempty :: Definitions Response)
1081− , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1082− ] ) js
1083− parseJSON _ = empty
1220+ parseJSON = sopSwaggerGenericParseJSON
10841221
10851222instance FromJSON SecurityScheme where
1086− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1223+ parseJSON = sopSwaggerGenericParseJSON
10871224
10881225instance FromJSON Schema where
1089− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1090− `withDefaults` [ "properties" .= (mempty :: InsOrdHashMap Text Schema)
1091− , "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
10921233
10931234instance FromJSON Header where
1094− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1235+ parseJSON = sopSwaggerGenericParseJSON
10951236
1096−instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1237+instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
10971238 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
10981239 <$> o .:? "collectionFormat"
10991240 <*> (o .: "items" >>= parseJSON)
11001241
1101−instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1102− parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
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
11031262 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
11041263 parseJSON _ = empty
11051264
@@ -1116,7 +1275,7 @@ instance FromJSON MimeList where
11161275 parseJSON js = (MimeList . map fromString) <$> parseJSON js
11171276
11181277instance FromJSON Param where
1119− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1278+ parseJSON = sopSwaggerGenericParseJSON
11201279
11211280instance FromJSON ParamAnySchema where
11221281 parseJSON js@(Object o) = do
@@ -1129,7 +1288,7 @@ instance FromJSON ParamAnySchema where
11291288 parseJSON _ = empty
11301289
11311290instance FromJSON ParamOtherSchema where
1132− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1291+ parseJSON = sopSwaggerGenericParseJSON
11331292
11341293instance FromJSON Responses where
11351294 parseJSON (Object o) = Responses
@@ -1143,18 +1302,16 @@ instance FromJSON Example where
11431302 pure $ Example (Map.mapKeys fromString m)
11441303
11451304instance FromJSON Response where
1146− parseJSON = genericParseJSON (jsonPrefix "response")
1147− `withDefaults` [ "headers" .= (mempty :: InsOrdHashMap HeaderName Header) ]
1305+ parseJSON = sopSwaggerGenericParseJSON
11481306
11491307instance FromJSON Operation where
1150− parseJSON = genericParseJSON (jsonPrefix "operation")
1151− `withDefaults` [ "security" .= ([] :: [SecurityRequirement])
1152− , "tags" .= ([] :: [Tag])
1153− , "parameters" .= ([] :: [Referenced Param]) ]
1308+ parseJSON = sopSwaggerGenericParseJSON
11541309
11551310instance FromJSON PathItem where
1156− parseJSON = genericParseJSON (jsonPrefix "pathItem")
1157− `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1311+ parseJSON = sopSwaggerGenericParseJSON
1312+
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
11581315
11591316instance FromJSON Reference where
11601317 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1180,28 +1337,35 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
11801337instance FromJSON Xml where
11811338 parseJSON = genericParseJSON (jsonPrefix "xml")
11821339
1183−instance FromJSON (SwaggerType Schema) where
1340+instance FromJSON (SwaggerType 'SwaggerKindSchema) where
11841341 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
11851342
1186−instance FromJSON (SwaggerType ParamOtherSchema) where
1343+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
11871344 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
11881345
1189−instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
1346+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
11901347 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
11911348
1192−instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
1349+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
11931350 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
11941351
1195−instance FromJSON (CollectionFormat ParamOtherSchema) where
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
11961357 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
11971358
1198−-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1199−-- @FromJSON (SwaggerItems t)@ are necessary here!
1200−-- Without the constraint the general instance will be used
1201−-- that only accepts common types (i.e. NOT object, null or file)
1202−-- and primitive array items.
1203−instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1204− parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
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
12051369
12061370-------------------------------------------------------------------------------
12071371-- TH splices
@@ -1219,3 +1383,45 @@ deriveGeneric ''SecurityScheme
12191383deriveGeneric ''Schema
12201384deriveGeneric ''ParamSchema
12211385deriveGeneric ''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