git.iko.soy/typeable/openapi3
on master help sign in
Derive FromJSON instances too
f508aa2Oleg Grenrus
src/Data/Swagger/Internal.hs+167−95
compare with master
unifiedsplit
@@ -8,6 +8,7 @@
8{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE StandaloneDeriving #-}
@@ -48,6 +49,10 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
48
49
49import Generics.SOP.TH (deriveGeneric)
50import Generics.SOP.TH (deriveGeneric)
50import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
51import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
52+ ,sopSwaggerGenericToJSONWithOpts
53+ ,sopSwaggerGenericParseJSON
54+ ,HasSwaggerAesonOptions(..)
55+ ,AesonDefaultValue(..)
51 ,mkSwaggerAesonOptions
56 ,mkSwaggerAesonOptions
52 ,saoAdditionalPairs
57 ,saoAdditionalPairs
53 ,saoSubObject)
58 ,saoSubObject)
@@ -343,8 +348,8 @@ data ParamOtherSchema = ParamOtherSchema
343 -- Default value is @False@.
348 -- Default value is @False@.
344 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
349 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
345
350
346− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
351+ , _paramOtherSchemaParamSchema :: ParamSchema SwaggerKindParamOtherSchema
347− } deriving (Eq, Show, Generic, Data, Typeable)
352+ } deriving (Eq, Show, Generic, Typeable, Data)
348
353
349-- | Items for @'SwaggerArray'@ schemas.
354-- | Items for @'SwaggerArray'@ schemas.
350--
355--
@@ -357,9 +362,9 @@ data ParamOtherSchema = ParamOtherSchema
357--
362--
358-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
363-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
359data SwaggerItems t where
364data SwaggerItems t where
360− SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
365+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
361− SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
366+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems SwaggerKindSchema
362− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
367+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems SwaggerKindSchema
363 deriving (Typeable)
368 deriving (Typeable)
364
369
365deriving instance Eq (SwaggerItems t)
370deriving instance Eq (SwaggerItems t)
@@ -369,17 +374,66 @@ deriving instance Show (SwaggerItems t)
369swaggerItemsPrimitiveConstr :: Constr
374swaggerItemsPrimitiveConstr :: Constr
370swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
375swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
371
376
377+swaggerItemsObjectConstr :: Constr
378+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
379+
380+swaggerItemsArrayConstr :: Constr
381+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
382+
372swaggerItemsDataType :: DataType
383swaggerItemsDataType :: DataType
373swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
384swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
374
385
386+-- Note: unfortunately we have to write these Data instances by hand,
387+-- to get better contexts / avoid duplicate name when using standalone deriving
388+
375−instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
389+instance Data t => Data (SwaggerItems (SwaggerKindNormal t)) where
390+ -- TODO: define gfoldl
376 gunfold k z c = case constrIndex c of
391 gunfold k z c = case constrIndex c of
377 1 -> k (k (z SwaggerItemsPrimitive))
392 1 -> k (k (z SwaggerItemsPrimitive))
378 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
393 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
379 toConstr _ = swaggerItemsPrimitiveConstr
394 toConstr _ = swaggerItemsPrimitiveConstr
380 dataTypeOf _ = swaggerItemsDataType
395 dataTypeOf _ = swaggerItemsDataType
381
396
397+-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
382−deriving instance Data (SwaggerItems Schema)
398+instance Data (SwaggerItems SwaggerKindParamOtherSchema) where
399+ -- TODO: define gfoldl
400+ gunfold k z c = case constrIndex c of
401+ 1 -> k (k (z SwaggerItemsPrimitive))
402+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
403+ toConstr _ = swaggerItemsPrimitiveConstr
404+ dataTypeOf _ = swaggerItemsDataType
405+
406+instance Data (SwaggerItems SwaggerKindSchema) where
407+ gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
408+ gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
409+ gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
410+
411+ gunfold k z c = case constrIndex c of
412+ 1 -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)"
413+ 2 -> k (z SwaggerItemsObject)
414+ 3 -> k (z SwaggerItemsArray)
415+
416+ toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
417+ toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
418+
419+ dataTypeOf _ = swaggerItemsDataType
420+
421+-- | Type used as a kind to avoid overlapping instances.
422+data SwaggerKind t
423+ = SwaggerKindNormal t
424+ | SwaggerKindParamOtherSchema
425+ | SwaggerKindSchema
426+
427+#if __GLASGLOW_HASKELL__ < 710
428+deriving instance Typeable 'SwaggerKindNormal
429+deriving instance Typeable 'SwaggerKindParamOtherSchema
430+deriving instance Typeable 'SwaggerKindSchema
431+#endif
432+
433+type family SwaggerKindType (k :: SwaggerKind *) :: *
434+type instance SwaggerKindType (SwaggerKindNormal t) = t
435+type instance SwaggerKindType SwaggerKindSchema = Schema
436+type instance SwaggerKindType SwaggerKindParamOtherSchema = ParamOtherSchema
383
437
384data SwaggerType t where
438data SwaggerType t where
385 SwaggerString :: SwaggerType t
439 SwaggerString :: SwaggerType t
@@ -387,9 +441,9 @@ data SwaggerType t where
387 SwaggerInteger :: SwaggerType t
441 SwaggerInteger :: SwaggerType t
388 SwaggerBoolean :: SwaggerType t
442 SwaggerBoolean :: SwaggerType t
389 SwaggerArray :: SwaggerType t
443 SwaggerArray :: SwaggerType t
390− SwaggerFile :: SwaggerType ParamOtherSchema
444+ SwaggerFile :: SwaggerType SwaggerKindParamOtherSchema
391− SwaggerNull :: SwaggerType Schema
445+ SwaggerNull :: SwaggerType SwaggerKindSchema
392− SwaggerObject :: SwaggerType Schema
446+ SwaggerObject :: SwaggerType SwaggerKindSchema
393 deriving (Typeable)
447 deriving (Typeable)
394
448
395deriving instance Eq (SwaggerType t)
449deriving instance Eq (SwaggerType t)
@@ -401,30 +455,30 @@ swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
401swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
455swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
402swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
456swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
403
457
404−swaggerCommonTypes :: [SwaggerType t]
458+swaggerCommonTypes :: [SwaggerType k]
405swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
459swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
406
460
407−swaggerParamTypes :: [SwaggerType ParamOtherSchema]
461+swaggerParamTypes :: [SwaggerType SwaggerKindParamOtherSchema]
408swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
462swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
409
463
410−swaggerSchemaTypes :: [SwaggerType Schema]
464+swaggerSchemaTypes :: [SwaggerType SwaggerKindSchema]
411swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
465swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
412
466
413swaggerTypeConstrs :: [Constr]
467swaggerTypeConstrs :: [Constr]
414−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
468+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType SwaggerKindSchema])
415 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
469 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
416
470
417−instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
471+instance Typeable t => Data (SwaggerType (SwaggerKindNormal t)) where
418 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
472 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
419 toConstr = swaggerTypeConstr
473 toConstr = swaggerTypeConstr
420 dataTypeOf = swaggerTypeDataType
474 dataTypeOf = swaggerTypeDataType
421
475
422−instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
476+instance Data (SwaggerType SwaggerKindParamOtherSchema) where
423 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
477 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
424 toConstr = swaggerTypeConstr
478 toConstr = swaggerTypeConstr
425 dataTypeOf = swaggerTypeDataType
479 dataTypeOf = swaggerTypeDataType
426
480
427−instance OVERLAPPABLE_ Data (SwaggerType Schema) where
481+instance Data (SwaggerType SwaggerKindSchema) where
428 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
482 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
429 toConstr = swaggerTypeConstr
483 toConstr = swaggerTypeConstr
430 dataTypeOf = swaggerTypeDataType
484 dataTypeOf = swaggerTypeDataType
@@ -464,7 +518,7 @@ data CollectionFormat t where
464 -- Corresponds to multiple parameter instances
518 -- Corresponds to multiple parameter instances
465 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
519 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
466 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
520 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
467− CollectionMulti :: CollectionFormat ParamOtherSchema
521+ CollectionMulti :: CollectionFormat SwaggerKindParamOtherSchema
468 deriving (Typeable)
522 deriving (Typeable)
469
523
470deriving instance Eq (CollectionFormat t)
524deriving instance Eq (CollectionFormat t)
@@ -480,12 +534,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
480collectionCommonFormats :: [CollectionFormat t]
534collectionCommonFormats :: [CollectionFormat t]
481collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
535collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
482
536
483−instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
537+instance Data t => Data (CollectionFormat (SwaggerKindNormal t)) where
484 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
538 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
485 toConstr = collectionFormatConstr
539 toConstr = collectionFormatConstr
486 dataTypeOf _ = collectionFormatDataType
540 dataTypeOf _ = collectionFormatDataType
487
541
488−deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
542+deriving instance Data (CollectionFormat SwaggerKindParamOtherSchema)
489
543
490type ParamName = Text
544type ParamName = Text
491
545
@@ -507,7 +561,7 @@ data Schema = Schema
507 , _schemaMaxProperties :: Maybe Integer
561 , _schemaMaxProperties :: Maybe Integer
508 , _schemaMinProperties :: Maybe Integer
562 , _schemaMinProperties :: Maybe Integer
509
563
510− , _schemaParamSchema :: ParamSchema Schema
564+ , _schemaParamSchema :: ParamSchema SwaggerKindSchema
511 } deriving (Eq, Show, Generic, Data, Typeable)
565 } deriving (Eq, Show, Generic, Data, Typeable)
512
566
513-- | A @'Schema'@ with an optional name.
567-- | A @'Schema'@ with an optional name.
@@ -520,7 +574,7 @@ data NamedSchema = NamedSchema
520-- | Regex pattern for @string@ type.
574-- | Regex pattern for @string@ type.
521type Pattern = Text
575type Pattern = Text
522
576
523−data ParamSchema t = ParamSchema
577+data ParamSchema (t :: SwaggerKind *) = ParamSchema
524 { -- | Declares the value of the parameter that the server will use if none is provided,
578 { -- | Declares the value of the parameter that the server will use if none is provided,
525 -- for example a @"count"@ to control the number of results per page might default to @100@
579 -- for example a @"count"@ to control the number of results per page might default to @100@
526 -- if not supplied by the client in the request.
580 -- if not supplied by the client in the request.
@@ -545,7 +599,7 @@ data ParamSchema t = ParamSchema
545 , _paramSchemaMultipleOf :: Maybe Scientific
599 , _paramSchemaMultipleOf :: Maybe Scientific
546 } deriving (Eq, Show, Generic, Typeable)
600 } deriving (Eq, Show, Generic, Typeable)
547
601
548−deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
602+deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
549
603
550data Xml = Xml
604data Xml = Xml
551 { -- | Replaces the name of the element/attribute used for the described schema property.
605 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -621,7 +675,7 @@ data Header = Header
621 { -- | A short description of the header.
675 { -- | A short description of the header.
622 _headerDescription :: Maybe Text
676 _headerDescription :: Maybe Text
623
677
624− , _headerParamSchema :: ParamSchema Header
678+ , _headerParamSchema :: ParamSchema (SwaggerKindNormal Header)
625 } deriving (Eq, Show, Generic, Data, Typeable)
679 } deriving (Eq, Show, Generic, Data, Typeable)
626
680
627data Example = Example { getExample :: Map MediaType Value }
681data Example = Example { getExample :: Map MediaType Value }
@@ -827,10 +881,6 @@ instance SwaggerMonoid ParamLocation where
827 swaggerMempty = ParamQuery
881 swaggerMempty = ParamQuery
828 swaggerMappend _ y = y
882 swaggerMappend _ y = y
829
883
830−instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
831− swaggerMempty = HashMap.empty
832− swaggerMappend = HashMap.unionWith mappend
833−
834instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
884instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
835 swaggerMempty = InsOrdHashMap.empty
885 swaggerMempty = InsOrdHashMap.empty
836 swaggerMappend = InsOrdHashMap.unionWith mappend
886 swaggerMappend = InsOrdHashMap.unionWith mappend
@@ -931,8 +981,7 @@ instance ToJSON OAuth2Flow where
931 , "tokenUrl" .= tokenUrl ]
981 , "tokenUrl" .= tokenUrl ]
932
982
933instance ToJSON OAuth2Params where
983instance ToJSON OAuth2Params where
934− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" &
984+ toJSON = sopSwaggerGenericToJSON
935− saoSubObject ?~ "flow"
936
985
937instance ToJSON SecuritySchemeType where
986instance ToJSON SecuritySchemeType where
938 toJSON SecuritySchemeBasic
987 toJSON SecuritySchemeBasic
@@ -945,22 +994,18 @@ instance ToJSON SecuritySchemeType where
945 <+> object [ "type" .= ("oauth2" :: Text) ]
994 <+> object [ "type" .= ("oauth2" :: Text) ]
946
995
947instance ToJSON Swagger where
996instance ToJSON Swagger where
948− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" &
997+ toJSON = sopSwaggerGenericToJSON
949− saoAdditionalPairs .~ [("swagger", "2.0")]
950
998
951instance ToJSON SecurityScheme where
999instance ToJSON SecurityScheme where
952− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" &
1000+ toJSON = sopSwaggerGenericToJSON
953− saoSubObject ?~ "type"
954
1001
955instance ToJSON Schema where
1002instance ToJSON Schema where
956− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" &
1003+ toJSON = sopSwaggerGenericToJSON
957− saoSubObject ?~ "paramSchema"
958
1004
959instance ToJSON Header where
1005instance ToJSON Header where
960− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" &
1006+ toJSON = sopSwaggerGenericToJSON
961− saoSubObject ?~ "paramSchema"
962
1007
963−instance ToJSON (SwaggerItems t) where
1008+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
964 toJSON (SwaggerItemsPrimitive fmt schema) = object
1009 toJSON (SwaggerItemsPrimitive fmt schema) = object
965 [ "collectionFormat" .= fmt
1010 [ "collectionFormat" .= fmt
966 , "items" .= schema ]
1011 , "items" .= schema ]
@@ -977,29 +1022,26 @@ instance ToJSON MimeList where
977 toJSON (MimeList xs) = toJSON (map show xs)
1022 toJSON (MimeList xs) = toJSON (map show xs)
978
1023
979instance ToJSON Param where
1024instance ToJSON Param where
980− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" &
1025+ toJSON = sopSwaggerGenericToJSON
981− saoSubObject ?~ "schema"
982
1026
983instance ToJSON ParamAnySchema where
1027instance ToJSON ParamAnySchema where
984 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1028 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
985 toJSON (ParamOther s) = toJSON s
1029 toJSON (ParamOther s) = toJSON s
986
1030
987instance ToJSON ParamOtherSchema where
1031instance ToJSON ParamOtherSchema where
988− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" &
1032+ toJSON = sopSwaggerGenericToJSON
989− saoSubObject ?~ "paramSchema"
990
1033
991instance ToJSON Responses where
1034instance ToJSON Responses where
992− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" &
1035+ toJSON = sopSwaggerGenericToJSON
993− saoSubObject ?~ "responses"
994
1036
995instance ToJSON Response where
1037instance ToJSON Response where
996− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response"
1038+ toJSON = sopSwaggerGenericToJSON
997
1039
998instance ToJSON Operation where
1040instance ToJSON Operation where
999− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation"
1041+ toJSON = sopSwaggerGenericToJSON
1000
1042
1001instance ToJSON PathItem where
1043instance ToJSON PathItem where
1002− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem"
1044+ toJSON = sopSwaggerGenericToJSON
1003
1045
1004instance ToJSON Example where
1046instance ToJSON Example where
1005 toJSON = toJSON . Map.mapKeys show . getExample
1047 toJSON = toJSON . Map.mapKeys show . getExample
@@ -1032,9 +1074,10 @@ instance ToJSON (CollectionFormat t) where
1032 toJSON CollectionPipes = "pipes"
1074 toJSON CollectionPipes = "pipes"
1033 toJSON CollectionMulti = "multi"
1075 toJSON CollectionMulti = "multi"
1034
1076
1035−instance ToJSON (ParamSchema t) where
1077+instance ToJSON (ParamSchema k) where
1078+ -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1079+ toJSON = sopSwaggerGenericToJSONWithOpts $
1036− toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" &
1080+ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1037− saoSubObject ?~ "items"
1038
1081
1039-- =======================================================================
1082-- =======================================================================
1040-- Manual FromJSON instances
1083-- Manual FromJSON instances
@@ -1054,7 +1097,7 @@ instance FromJSON OAuth2Flow where
1054 parseJSON _ = empty
1097 parseJSON _ = empty
1055
1098
1056instance FromJSON OAuth2Params where
1099instance FromJSON OAuth2Params where
1057− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1100+ parseJSON = sopSwaggerGenericParseJSON
1058
1101
1059instance FromJSON SecuritySchemeType where
1102instance FromJSON SecuritySchemeType where
1060 parseJSON js@(Object o) = do
1103 parseJSON js@(Object o) = do
@@ -1067,38 +1110,28 @@ instance FromJSON SecuritySchemeType where
1067 parseJSON _ = empty
1110 parseJSON _ = empty
1068
1111
1069instance FromJSON Swagger where
1112instance FromJSON Swagger where
1070− parseJSON js@(Object o) = do
1113+ parseJSON = sopSwaggerGenericParseJSON
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
1084
1114
1085instance FromJSON SecurityScheme where
1115instance FromJSON SecurityScheme where
1086− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1116+ parseJSON = sopSwaggerGenericParseJSON
1087
1117
1088instance FromJSON Schema where
1118instance FromJSON Schema where
1089− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1119+ parseJSON = sopSwaggerGenericParseJSON
1090− `withDefaults` [ "properties" .= (mempty :: InsOrdHashMap Text Schema)
1091− , "required" .= ([] :: [ParamName]) ]
1092
1120
1093instance FromJSON Header where
1121instance FromJSON Header where
1094− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1122+ parseJSON = sopSwaggerGenericParseJSON
1095
1123
1096−instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1124+instance (FromJSON (CollectionFormat (SwaggerKindNormal t)), FromJSON (ParamSchema (SwaggerKindNormal t))) => FromJSON (SwaggerItems (SwaggerKindNormal t)) where
1097 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1125 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1098 <$> o .:? "collectionFormat"
1126 <$> o .:? "collectionFormat"
1099 <*> (o .: "items" >>= parseJSON)
1127 <*> (o .: "items" >>= parseJSON)
1100
1128
1129+instance FromJSON (SwaggerItems SwaggerKindParamOtherSchema) where
1130+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1131+ <$> o .:? "collectionFormat"
1132+ <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1133+
1101−instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1134+instance FromJSON (SwaggerItems SwaggerKindSchema) where
1102 parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1135 parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1103 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1136 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1104 parseJSON _ = empty
1137 parseJSON _ = empty
@@ -1116,7 +1149,7 @@ instance FromJSON MimeList where
1116 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1149 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1117
1150
1118instance FromJSON Param where
1151instance FromJSON Param where
1119− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1152+ parseJSON = sopSwaggerGenericParseJSON
1120
1153
1121instance FromJSON ParamAnySchema where
1154instance FromJSON ParamAnySchema where
1122 parseJSON js@(Object o) = do
1155 parseJSON js@(Object o) = do
@@ -1129,7 +1162,7 @@ instance FromJSON ParamAnySchema where
1129 parseJSON _ = empty
1162 parseJSON _ = empty
1130
1163
1131instance FromJSON ParamOtherSchema where
1164instance FromJSON ParamOtherSchema where
1132− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1165+ parseJSON = sopSwaggerGenericParseJSON
1133
1166
1134instance FromJSON Responses where
1167instance FromJSON Responses where
1135 parseJSON (Object o) = Responses
1168 parseJSON (Object o) = Responses
@@ -1143,18 +1176,13 @@ instance FromJSON Example where
1143 pure $ Example (Map.mapKeys fromString m)
1176 pure $ Example (Map.mapKeys fromString m)
1144
1177
1145instance FromJSON Response where
1178instance FromJSON Response where
1146− parseJSON = genericParseJSON (jsonPrefix "response")
1179+ parseJSON = sopSwaggerGenericParseJSON
1147− `withDefaults` [ "headers" .= (mempty :: InsOrdHashMap HeaderName Header) ]
1148
1180
1149instance FromJSON Operation where
1181instance FromJSON Operation where
1150− parseJSON = genericParseJSON (jsonPrefix "operation")
1182+ parseJSON = sopSwaggerGenericParseJSON
1151− `withDefaults` [ "security" .= ([] :: [SecurityRequirement])
1152− , "tags" .= ([] :: [Tag])
1153− , "parameters" .= ([] :: [Referenced Param]) ]
1154
1183
1155instance FromJSON PathItem where
1184instance FromJSON PathItem where
1156− parseJSON = genericParseJSON (jsonPrefix "pathItem")
1185+ parseJSON = sopSwaggerGenericParseJSON
1157− `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1158
1186
1159instance FromJSON Reference where
1187instance FromJSON Reference where
1160 parseJSON (Object o) = Reference <$> o .: "$ref"
1188 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1180,28 +1208,31 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
1180instance FromJSON Xml where
1208instance FromJSON Xml where
1181 parseJSON = genericParseJSON (jsonPrefix "xml")
1209 parseJSON = genericParseJSON (jsonPrefix "xml")
1182
1210
1183−instance FromJSON (SwaggerType Schema) where
1211+instance FromJSON (SwaggerType SwaggerKindSchema) where
1184 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1212 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1185
1213
1186−instance FromJSON (SwaggerType ParamOtherSchema) where
1214+instance FromJSON (SwaggerType SwaggerKindParamOtherSchema) where
1187 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1215 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1188
1216
1189−instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
1217+instance FromJSON (SwaggerType (SwaggerKindNormal t)) where
1190 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1218 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1191
1219
1192−instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
1220+instance FromJSON (CollectionFormat (SwaggerKindNormal t)) where
1193 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1221 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1194
1222
1223+-- NOTE: There aren't collections of 'Schema'
1224+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1225+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1226+
1195−instance FromJSON (CollectionFormat ParamOtherSchema) where
1227+instance FromJSON (CollectionFormat SwaggerKindParamOtherSchema) where
1196 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1228 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1197
1229
1198−-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1230+instance (FromJSON (SwaggerType (SwaggerKindNormal t)), FromJSON (SwaggerItems (SwaggerKindNormal t))) => FromJSON (ParamSchema (SwaggerKindNormal t)) where
1199−-- @FromJSON (SwaggerItems t)@ are necessary here!
1231+ parseJSON = sopSwaggerGenericParseJSON
1200−-- Without the constraint the general instance will be used
1232+instance FromJSON (ParamSchema SwaggerKindParamOtherSchema) where
1201−-- that only accepts common types (i.e. NOT object, null or file)
1233+ parseJSON = sopSwaggerGenericParseJSON
1202−-- and primitive array items.
1234+instance FromJSON (ParamSchema SwaggerKindSchema) where
1203−instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1235+ parseJSON = sopSwaggerGenericParseJSON
1204− parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1205
1236
1206-------------------------------------------------------------------------------
1237-------------------------------------------------------------------------------
1207-- TH splices
1238-- TH splices
@@ -1219,3 +1250,44 @@ deriveGeneric ''SecurityScheme
1219deriveGeneric ''Schema
1250deriveGeneric ''Schema
1220deriveGeneric ''ParamSchema
1251deriveGeneric ''ParamSchema
1221deriveGeneric ''Swagger
1252deriveGeneric ''Swagger
1253+
1254+instance HasSwaggerAesonOptions Header where
1255+ swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1256+instance HasSwaggerAesonOptions OAuth2Params where
1257+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1258+instance HasSwaggerAesonOptions Operation where
1259+ swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1260+instance HasSwaggerAesonOptions Param where
1261+ swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1262+instance HasSwaggerAesonOptions ParamOtherSchema where
1263+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1264+instance HasSwaggerAesonOptions PathItem where
1265+ swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1266+instance HasSwaggerAesonOptions Response where
1267+ swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1268+instance HasSwaggerAesonOptions Responses where
1269+ swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1270+instance HasSwaggerAesonOptions SecurityScheme where
1271+ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1272+instance HasSwaggerAesonOptions Schema where
1273+ swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1274+instance HasSwaggerAesonOptions Swagger where
1275+ swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1276+
1277+instance HasSwaggerAesonOptions (ParamSchema (SwaggerKindNormal t)) where
1278+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1279+instance HasSwaggerAesonOptions (ParamSchema SwaggerKindParamOtherSchema) where
1280+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1281+-- NOTE: Schema doesn't have 'items' sub object!
1282+instance HasSwaggerAesonOptions (ParamSchema SwaggerKindSchema) where
1283+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1284+
1285+instance AesonDefaultValue (ParamSchema s)
1286+instance AesonDefaultValue OAuth2Flow
1287+instance AesonDefaultValue Responses
1288+instance AesonDefaultValue ParamAnySchema
1289+instance AesonDefaultValue SecuritySchemeType
1290+instance AesonDefaultValue (SwaggerType a)
1291+instance AesonDefaultValue MimeList where defaultValue = Just mempty
1292+instance AesonDefaultValue Info
1293+instance AesonDefaultValue ParamLocation
src/Data/Swagger/Internal/AesonUtils.hs+164−16
@@ -6,8 +6,12 @@
6{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TemplateHaskell #-}
7module Data.Swagger.Internal.AesonUtils (
7module Data.Swagger.Internal.AesonUtils (
8 -- * Generic functions
8 -- * Generic functions
9+ AesonDefaultValue(..),
9 sopSwaggerGenericToJSON,
10 sopSwaggerGenericToJSON,
11+ sopSwaggerGenericToJSONWithOpts,
12+ sopSwaggerGenericParseJSON,
10 -- * Options
13 -- * Options
14+ HasSwaggerAesonOptions(..),
11 SwaggerAesonOptions,
15 SwaggerAesonOptions,
12 mkSwaggerAesonOptions,
16 mkSwaggerAesonOptions,
13 saoPrefix,
17 saoPrefix,
@@ -18,15 +22,20 @@ module Data.Swagger.Internal.AesonUtils (
18import Prelude ()
22import Prelude ()
19import Prelude.Compat
23import Prelude.Compat
20
24
25+import Control.Applicative ((<|>))
21−import Control.Lens (makeLenses, (^.))
26+import Control.Lens (makeLenses, (^.))
27+import Control.Monad (unless)
22−import Data.Aeson (ToJSON(..), Value(..), object)
28+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
23−import Data.Text (Text)
29+import Data.Aeson.Types (Parser)
24−import Data.Char (toLower, isUpper)
30+import Data.Char (toLower, isUpper)
31+import Data.Text (Text)
25
32
26import Generics.SOP
33import Generics.SOP
27
34
28import qualified Data.Text as T
35import qualified Data.Text as T
29import qualified Data.HashMap.Strict as HM
36import qualified Data.HashMap.Strict as HM
37+import qualified Data.Set as Set
38+import qualified Data.HashMap.Strict.InsOrd as InsOrd
30
39
31-------------------------------------------------------------------------------
40-------------------------------------------------------------------------------
32-- SwaggerAesonOptions
41-- SwaggerAesonOptions
@@ -45,10 +54,31 @@ mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
45
54
46makeLenses ''SwaggerAesonOptions
55makeLenses ''SwaggerAesonOptions
47
56
57+class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
58+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions
59+
60+ -- So far we use only default definitions
61+ aesonDefaults :: proxy a -> POP Maybe (Code a)
62+ aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
63+
48-------------------------------------------------------------------------------
64-------------------------------------------------------------------------------
49-- Generics
65-- Generics
50-------------------------------------------------------------------------------
66-------------------------------------------------------------------------------
51
67
68+class AesonDefaultValue a where
69+ defaultValue :: Maybe a
70+ defaultValue = Nothing
71+
72+instance AesonDefaultValue Text where defaultValue = Nothing
73+instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
74+instance AesonDefaultValue [a] where defaultValue = Just []
75+instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
76+instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
77+
78+-------------------------------------------------------------------------------
79+-- ToJSON
80+-------------------------------------------------------------------------------
81+
52-- | Generic serialisation for swagger records.
82-- | Generic serialisation for swagger records.
53--
83--
54-- Features
84-- Features
@@ -57,36 +87,154 @@ makeLenses ''SwaggerAesonOptions
57-- * possible to add fields
87-- * possible to add fields
58-- * possible to merge sub-object
88-- * possible to merge sub-object
59sopSwaggerGenericToJSON
89sopSwaggerGenericToJSON
90+ :: forall a xs.
91+ ( Generic a
92+ , HasDatatypeInfo a
93+ , HasSwaggerAesonOptions a
94+ , All2 ToJSON (Code a)
95+ , All2 Eq (Code a)
96+ , Code a ~ '[xs]
97+ )
98+ => a
99+ -> Value
100+sopSwaggerGenericToJSON x =
101+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
102+ in object (opts ^. saoAdditionalPairs ++ ps)
103+ where
104+ proxy = Proxy :: Proxy a
105+ opts = swaggerAesonOptions proxy
106+
107+-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
108+--
109+-- Also uses default `aesonDefaults`
110+sopSwaggerGenericToJSONWithOpts
111+ :: forall a xs.
112+ ( Generic a
113+ , All2 AesonDefaultValue (Code a)
60− :: forall a xs. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a), Code a ~ '[xs])
114+ , HasDatatypeInfo a
115+ , All2 ToJSON (Code a)
116+ , All2 Eq (Code a)
117+ , Code a ~ '[xs]
118+ )
61 => SwaggerAesonOptions
119 => SwaggerAesonOptions
62 -> a
120 -> a
63 -> Value
121 -> Value
64−sopSwaggerGenericToJSON opts x =
122+sopSwaggerGenericToJSONWithOpts opts x =
65− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo (Proxy :: Proxy a))
123+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
66 in object (opts ^. saoAdditionalPairs ++ ps)
124 in object (opts ^. saoAdditionalPairs ++ ps)
125+ where
126+ proxy = Proxy :: Proxy a
127+ defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
67
128
68−sopSwaggerGenericToJSON' :: All2 ToJSON '[xs] => SwaggerAesonOptions -> SOP I '[xs] -> DatatypeInfo '[xs] -> [(Text, Value)]
129+sopSwaggerGenericToJSON'
130+ :: (All2 ToJSON '[xs], All2 Eq '[xs])
131+ => SwaggerAesonOptions
132+ -> SOP I '[xs]
133+ -> DatatypeInfo '[xs]
134+ -> POP Maybe '[xs]
135+ -> [(Text, Value)]
69−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) =
136+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
70− sopSwaggerGenericToJSON'' opts fields fieldsInfo
137+ sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
71
138
72−sopSwaggerGenericToJSON'' :: All ToJSON xs => SwaggerAesonOptions -> NP I xs -> NP FieldInfo xs -> [(Text, Value)]
139+sopSwaggerGenericToJSON''
140+ :: (All ToJSON xs, All Eq xs)
141+ => SwaggerAesonOptions
142+ -> NP I xs
143+ -> NP FieldInfo xs
144+ -> NP Maybe xs
145+ -> [(Text, Value)]
73sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
146sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
74 where
147 where
75− go :: All ToJSON ys => NP I ys -> NP FieldInfo ys -> [(Text, Value)]
148+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [(Text, Value)]
76− go Nil Nil = []
149+ go Nil Nil Nil = []
77− go (I x :* xs) (FieldInfo name :* names)
150+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)
78 | Just name' == sub = case json of
151 | Just name' == sub = case json of
79 Object m -> HM.toList m ++ rest
152 Object m -> HM.toList m ++ rest
80 Null -> rest
153 Null -> rest
81 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
154 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
82− | json == Null || json == Array mempty || json == Object mempty =
155+ -- If default value: omit it.
156+ | Just x == def =
83 rest
157 rest
84 | otherwise =
158 | otherwise =
85 (T.pack name', json) : rest
159 (T.pack name', json) : rest
86 where
160 where
87 json = toJSON x
161 json = toJSON x
88 name' = fieldNameModifier name
162 name' = fieldNameModifier name
89− rest = go xs names
163+ rest = go xs names defs
164+
165+ fieldNameModifier = modifier . drop 1
166+ modifier = lowerFirstUppers . drop (length prefix)
167+ lowerFirstUppers s = map toLower x ++ y
168+ where (x, y) = span isUpper s
169+
170+-------------------------------------------------------------------------------
171+-- FromJSON
172+-------------------------------------------------------------------------------
173+
174+sopSwaggerGenericParseJSON
175+ :: forall a xs.
176+ ( Generic a
177+ , HasDatatypeInfo a
178+ , HasSwaggerAesonOptions a
179+ , All2 FromJSON (Code a)
180+ , All2 Eq (Code a)
181+ , Code a ~ '[xs]
182+ )
183+ => Value
184+ -> Parser a
185+sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
186+ let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
187+ in do
188+ traverse (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
189+ to <$> ps
190+ where
191+ proxy = Proxy :: Proxy a
192+ opts = swaggerAesonOptions proxy
193+
194+ parseAdditionalField :: Object -> (Text, Value) -> Parser ()
195+ parseAdditionalField obj (k, v) = do
196+ v' <- obj .: k
197+ unless (v == v') $ fail $
198+ "Additonal field don't match for key " ++ T.unpack k
199+ ++ ": " ++ show v
200+ ++ " /= " ++ show v'
201+
202+sopSwaggerGenericParseJSON'
203+ :: (All2 FromJSON '[xs], All2 Eq '[xs])
204+ => SwaggerAesonOptions
205+ -> Object
206+ -> DatatypeInfo '[xs]
207+ -> POP Maybe '[xs]
208+ -> Parser (SOP I '[xs])
209+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
210+ SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
211+
212+sopSwaggerGenericParseJSON''
213+ :: (All FromJSON xs, All Eq xs)
214+ => SwaggerAesonOptions
215+ -> Object
216+ -> NP FieldInfo xs
217+ -> NP Maybe xs
218+ -> Parser (NP I xs)
219+sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
220+ where
221+ go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
222+ go Nil Nil = pure Nil
223+ go (FieldInfo name :* names) (def :* defs)
224+ | Just name' == sub =
225+ -- Note: we might strip fields of outer structure.
226+ cons <$> (withDef $ parseJSON $ Object obj) <*> rest
227+ | otherwise = case def of
228+ Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
229+ Nothing -> cons <$> obj .: T.pack name' <*> rest
230+ where
231+ cons h t = I h :* t
232+ name' = fieldNameModifier name
233+ rest = go names defs
234+
235+ withDef = case def of
236+ Just def' -> (<|> pure def')
237+ Nothing -> id
90
238
91 fieldNameModifier = modifier . drop 1
239 fieldNameModifier = modifier . drop 1
92 modifier = lowerFirstUppers . drop (length prefix)
240 modifier = lowerFirstUppers . drop (length prefix)
src/Data/Swagger/Internal/Schema.hs+2−1
@@ -3,6 +3,7 @@
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE DataKinds #-}
6{-# LANGUAGE OverloadedLists #-}
7{-# LANGUAGE OverloadedLists #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE PackageImports #-}
9{-# LANGUAGE PackageImports #-}
@@ -615,7 +616,7 @@ gdeclareSchemaRef opts proxy = do
615 return $ Ref (Reference name)
616 return $ Ref (Reference name)
616 _ -> Inline <$> gdeclareSchema opts proxy
617 _ -> Inline <$> gdeclareSchema opts proxy
617
618
618−appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
619+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
619appendItem x Nothing = Just (SwaggerItemsArray [x])
620appendItem x Nothing = Just (SwaggerItemsArray [x])
620appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
621appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
621appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
622appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
src/Data/Swagger/Internal/Utils.hs−31
@@ -55,17 +55,6 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
55 Just x -> z x
55 Just x -> z x
56 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
56 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
57
57
58−hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
59−hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
60−
61−hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
62−hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
63− where
64− g (x, y) = (\a -> (a, y)) <$> f x
65−
66−hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
67−hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
68−
69jsonPrefix :: String -> Options
58jsonPrefix :: String -> Options
70jsonPrefix prefix = defaultOptions
59jsonPrefix prefix = defaultOptions
71 { fieldLabelModifier = modifier . drop 1
60 { fieldLabelModifier = modifier . drop 1
@@ -87,29 +76,10 @@ parseOneOf xs js =
87 where
76 where
88 ys = zip (map toJSON xs) xs
77 ys = zip (map toJSON xs) xs
89
78
90−{-# DEPRECATED omitEmpties "will be removed" #-}
91−omitEmpties :: Value -> Value
92−omitEmpties (Object o) = Object (HashMap.filter nonEmpty o)
93− where
94− nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
95−omitEmpties js = js
96−
97−genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
98−genericParseJSONWithSub sub opts js@(Object o)
99− = genericParseJSON opts js -- try without subjson
100− <|> genericParseJSON opts js' -- try with subjson
101− where
102− js' = Object (HashMap.insert sub (Object o) o)
103−genericParseJSONWithSub _ _ _ = fail "genericParseJSONWithSub: given json is not an object"
104−
105(<+>) :: Value -> Value -> Value
79(<+>) :: Value -> Value -> Value
106Object x <+> Object y = Object (x <> y)
80Object x <+> Object y = Object (x <> y)
107_ <+> _ = error "<+>: merging non-objects"
81_ <+> _ = error "<+>: merging non-objects"
108
82
109−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
110−withDefaults parser defs js@(Object _) = parser (js <+> object defs)
111−withDefaults _ _ _ = empty
112−
113genericMempty :: (Generic a, GMonoid (Rep a)) => a
83genericMempty :: (Generic a, GMonoid (Rep a)) => a
114genericMempty = to gmempty
84genericMempty = to gmempty
115
85
@@ -165,4 +135,3 @@ instance SwaggerMonoid (Maybe a) where
165 swaggerMempty = Nothing
135 swaggerMempty = Nothing
166 swaggerMappend x Nothing = x
136 swaggerMappend x Nothing = x
167 swaggerMappend _ y = y
137 swaggerMappend _ y = y
168−
src/Data/Swagger/Lens.hs+8−7
@@ -7,6 +7,7 @@
7{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE DataKinds #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
11{-# OPTIONS_GHC -fno-warn-orphans #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
12#include "overlapping-compat.h"
13#include "overlapping-compat.h"
@@ -59,14 +60,14 @@ makePrisms ''Referenced
59
60
60-- ** 'SwaggerItems' prisms
61-- ** 'SwaggerItems' prisms
61
62
62−_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
63+_SwaggerItemsArray :: Review (SwaggerItems SwaggerKindSchema) [Referenced Schema]
63_SwaggerItemsArray
64_SwaggerItemsArray
64 = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
65 = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
65 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
66 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
66 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
67 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
67 SwaggerItemsArray a -> Right a
68 SwaggerItemsArray a -> Right a
68
69
69−_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
70+_SwaggerItemsObject :: Review (SwaggerItems SwaggerKindSchema) (Referenced Schema)
70_SwaggerItemsObject
71_SwaggerItemsObject
71 = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
72 = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
72 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
73 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
@@ -91,13 +92,13 @@ instance At Responses where at n = responses . at n
91instance Ixed Operation where ix n = responses . ix n
92instance Ixed Operation where ix n = responses . ix n
92instance At Operation where at n = responses . at n
93instance At Operation where at n = responses . at n
93
94
94−instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema
95+instance HasParamSchema NamedSchema (ParamSchema SwaggerKindSchema) where paramSchema = schema.paramSchema
95
96
96-- HasType instances
97-- HasType instances
97−instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
98+instance HasType Header (SwaggerType (SwaggerKindNormal Header)) where type_ = paramSchema.type_
98−instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
99+instance HasType Schema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_
99−instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_
100+instance HasType NamedSchema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_
100−instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
101+instance HasType ParamOtherSchema (SwaggerType SwaggerKindParamOtherSchema) where type_ = paramSchema.type_
101
102
102-- HasDefault instances
103-- HasDefault instances
103instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
104instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
swagger2.cabal−1
@@ -45,7 +45,6 @@ library
45 , containers
45 , containers
46 , hashable
46 , hashable
47 , generics-sop >=0.2 && <0.3
47 , generics-sop >=0.2 && <0.3
48− , generics-sop-lens >=0.1.0.0 && <0.2
49 , http-media
48 , http-media
50 , insert-ordered-containers >=0.1.0.0 && <0.2
49 , insert-ordered-containers >=0.1.0.0 && <0.2
51 , lens
50 , lens
test/Data/Swagger/ParamSchemaSpec.hs+3−1
@@ -1,4 +1,5 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE QuasiQuotes #-}
5{-# LANGUAGE QuasiQuotes #-}
@@ -11,12 +12,13 @@ import Data.Proxy
11import GHC.Generics
12import GHC.Generics
12
13
13import Data.Swagger
14import Data.Swagger
15+import Data.Swagger.Internal (SwaggerKind(..))
14
16
15import SpecCommon
17import SpecCommon
16import Test.Hspec
18import Test.Hspec
17
19
18checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
20checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
19−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js
20
22
21spec :: Spec
23spec :: Spec
22spec = do
24spec = do