git.iko.soy/typeable/openapi3
on master help sign in
Merge pull request #56 from phadej/ordhashmap
e1ccb48Nickolay Kudasov
src/Data/Swagger.hs+3−3
compare with master
unifiedsplit
@@ -186,7 +186,7 @@ import Data.Swagger.Internal
186-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
186-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
187-- & at 404 ?~ "User info not found")) ]
187-- & at 404 ?~ "User info not found")) ]
188-- :}
188-- :}
189−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"
189+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
190--
190--
191-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
191-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
192-- which produces @application/json@ output. It should respond with code @200@ and body specified
192-- which produces @application/json@ output. It should respond with code @200@ and body specified
@@ -205,7 +205,7 @@ import Data.Swagger.Internal
205-- & type_ .~ SwaggerBoolean
205-- & type_ .~ SwaggerBoolean
206-- & description ?~ "To be or not to be"
206-- & description ?~ "To be or not to be"
207-- :}
207-- :}
208−-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
208+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
209--
209--
210-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
210-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
@@ -271,7 +271,7 @@ import Data.Swagger.Internal
271-- >>> encode (Person "David" 28)
271-- >>> encode (Person "David" 28)
272-- "{\"age\":28,\"name\":\"David\"}"
272-- "{\"age\":28,\"name\":\"David\"}"
273-- >>> encode $ toSchema (Proxy :: Proxy Person)
273-- >>> encode $ toSchema (Proxy :: Proxy Person)
274−-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
274+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
275
275
276-- $manipulation
276-- $manipulation
277-- Sometimes you have to work with an imported or generated @'Swagger'@.
277-- Sometimes you have to work with an imported or generated @'Swagger'@.
src/Data/Swagger/Internal.hs+227−106
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveGeneric #-}
@@ -11,19 +12,23 @@
11{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ <710
19+{-# LANGUAGE PolyKinds #-}
20+#endif
15#include "overlapping-compat.h"
21#include "overlapping-compat.h"
16module Data.Swagger.Internal where
22module Data.Swagger.Internal where
17
23
18import Prelude ()
24import Prelude ()
19import Prelude.Compat
25import Prelude.Compat
20
26
27+import Control.Lens ((&), (.~), (?~))
21import Control.Applicative
28import Control.Applicative
22−import Control.Monad
23import Data.Aeson
29import Data.Aeson
24import qualified Data.Aeson.Types as JSON
30import qualified Data.Aeson.Types as JSON
25import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
31import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
26−import Data.HashMap.Strict (HashMap)
27import qualified Data.HashMap.Strict as HashMap
32import qualified Data.HashMap.Strict as HashMap
28import Data.Map (Map)
33import Data.Map (Map)
29import qualified Data.Map as Map
34import qualified Data.Map as Map
@@ -38,10 +43,29 @@ import Network (HostName, PortNumber)
38import Network.HTTP.Media (MediaType)
43import Network.HTTP.Media (MediaType)
39import Text.Read (readMaybe)
44import Text.Read (readMaybe)
40
45
46+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
47+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
48+
49+import Generics.SOP.TH (deriveGeneric)
50+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
51+ ,sopSwaggerGenericToJSONWithOpts
52+ ,sopSwaggerGenericParseJSON
53+ ,HasSwaggerAesonOptions(..)
54+ ,AesonDefaultValue(..)
55+ ,mkSwaggerAesonOptions
56+ ,saoAdditionalPairs
57+ ,saoSubObject)
41import Data.Swagger.Internal.Utils
58import Data.Swagger.Internal.Utils
42
59
60+#if MIN_VERSION_aeson(0,10,0)
61+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
62+#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding
63+#else
64+#define DEFINE_TOENCODING
65+#endif
66+
43-- | A list of definitions that can be used in references.
67-- | A list of definitions that can be used in references.
44−type Definitions = HashMap Text
68+type Definitions = InsOrdHashMap Text
45
69
46-- | This is the root document object for the API specification.
70-- | This is the root document object for the API specification.
47data Swagger = Swagger
71data Swagger = Swagger
@@ -73,7 +97,7 @@ data Swagger = Swagger
73 -- | The available paths and operations for the API.
97 -- | The available paths and operations for the API.
74 -- Holds the relative paths to the individual endpoints.
98 -- Holds the relative paths to the individual endpoints.
75 -- The path is appended to the @'basePath'@ in order to construct the full URL.
99 -- The path is appended to the @'basePath'@ in order to construct the full URL.
76− , _swaggerPaths :: HashMap FilePath PathItem
100+ , _swaggerPaths :: InsOrdHashMap FilePath PathItem
77
101
78 -- | An object to hold data types produced and consumed by operations.
102 -- | An object to hold data types produced and consumed by operations.
79 , _swaggerDefinitions :: Definitions Schema
103 , _swaggerDefinitions :: Definitions Schema
@@ -330,8 +354,8 @@ data ParamOtherSchema = ParamOtherSchema
330 -- Default value is @False@.
354 -- Default value is @False@.
331 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
355 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
332
356
333− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
357+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
334− } deriving (Eq, Show, Generic, Data, Typeable)
358+ } deriving (Eq, Show, Generic, Typeable, Data)
335
359
336-- | Items for @'SwaggerArray'@ schemas.
360-- | Items for @'SwaggerArray'@ schemas.
337--
361--
@@ -344,9 +368,9 @@ data ParamOtherSchema = ParamOtherSchema
344--
368--
345-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
369-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
346data SwaggerItems t where
370data SwaggerItems t where
347− SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
371+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
348− SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
372+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
349− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
373+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
350 deriving (Typeable)
374 deriving (Typeable)
351
375
352deriving instance Eq (SwaggerItems t)
376deriving instance Eq (SwaggerItems t)
@@ -356,17 +380,66 @@ deriving instance Show (SwaggerItems t)
356swaggerItemsPrimitiveConstr :: Constr
380swaggerItemsPrimitiveConstr :: Constr
357swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
381swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
358
382
383+swaggerItemsObjectConstr :: Constr
384+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
385+
386+swaggerItemsArrayConstr :: Constr
387+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
388+
359swaggerItemsDataType :: DataType
389swaggerItemsDataType :: DataType
360swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
390swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
361
391
392+-- Note: unfortunately we have to write these Data instances by hand,
393+-- to get better contexts / avoid duplicate name when using standalone deriving
394+
362−instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
395+instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where
396+ -- TODO: define gfoldl
363 gunfold k z c = case constrIndex c of
397 gunfold k z c = case constrIndex c of
364 1 -> k (k (z SwaggerItemsPrimitive))
398 1 -> k (k (z SwaggerItemsPrimitive))
365 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
399 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
366 toConstr _ = swaggerItemsPrimitiveConstr
400 toConstr _ = swaggerItemsPrimitiveConstr
367 dataTypeOf _ = swaggerItemsDataType
401 dataTypeOf _ = swaggerItemsDataType
368
402
403+-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
369−deriving instance Data (SwaggerItems Schema)
404+instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
405+ -- TODO: define gfoldl
406+ gunfold k z c = case constrIndex c of
407+ 1 -> k (k (z SwaggerItemsPrimitive))
408+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
409+ toConstr _ = swaggerItemsPrimitiveConstr
410+ dataTypeOf _ = swaggerItemsDataType
411+
412+instance Data (SwaggerItems 'SwaggerKindSchema) where
413+ gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
414+ gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
415+ gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
416+
417+ gunfold k z c = case constrIndex c of
418+ 2 -> k (z SwaggerItemsObject)
419+ 3 -> k (z SwaggerItemsArray)
420+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."
421+
422+ toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"
423+ toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
424+ toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
425+
426+ dataTypeOf _ = swaggerItemsDataType
427+
428+-- | Type used as a kind to avoid overlapping instances.
429+data SwaggerKind t
430+ = SwaggerKindNormal t
431+ | SwaggerKindParamOtherSchema
432+ | SwaggerKindSchema
433+ deriving (Typeable)
434+
435+deriving instance Typeable 'SwaggerKindNormal
436+deriving instance Typeable 'SwaggerKindParamOtherSchema
437+deriving instance Typeable 'SwaggerKindSchema
438+
439+type family SwaggerKindType (k :: SwaggerKind *) :: *
440+type instance SwaggerKindType ('SwaggerKindNormal t) = t
441+type instance SwaggerKindType 'SwaggerKindSchema = Schema
442+type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema
370
443
371data SwaggerType t where
444data SwaggerType t where
372 SwaggerString :: SwaggerType t
445 SwaggerString :: SwaggerType t
@@ -374,9 +447,9 @@ data SwaggerType t where
374 SwaggerInteger :: SwaggerType t
447 SwaggerInteger :: SwaggerType t
375 SwaggerBoolean :: SwaggerType t
448 SwaggerBoolean :: SwaggerType t
376 SwaggerArray :: SwaggerType t
449 SwaggerArray :: SwaggerType t
377− SwaggerFile :: SwaggerType ParamOtherSchema
450+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
378− SwaggerNull :: SwaggerType Schema
451+ SwaggerNull :: SwaggerType 'SwaggerKindSchema
379− SwaggerObject :: SwaggerType Schema
452+ SwaggerObject :: SwaggerType 'SwaggerKindSchema
380 deriving (Typeable)
453 deriving (Typeable)
381
454
382deriving instance Eq (SwaggerType t)
455deriving instance Eq (SwaggerType t)
@@ -388,30 +461,30 @@ swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
388swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
461swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
389swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
462swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
390
463
391−swaggerCommonTypes :: [SwaggerType t]
464+swaggerCommonTypes :: [SwaggerType k]
392swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
465swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
393
466
394−swaggerParamTypes :: [SwaggerType ParamOtherSchema]
467+swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
395swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
468swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
396
469
397−swaggerSchemaTypes :: [SwaggerType Schema]
470+swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
398swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
471swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
399
472
400swaggerTypeConstrs :: [Constr]
473swaggerTypeConstrs :: [Constr]
401−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
474+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
402 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
475 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
403
476
404−instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
477+instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
405 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
478 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
406 toConstr = swaggerTypeConstr
479 toConstr = swaggerTypeConstr
407 dataTypeOf = swaggerTypeDataType
480 dataTypeOf = swaggerTypeDataType
408
481
409−instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
482+instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
410 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
483 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
411 toConstr = swaggerTypeConstr
484 toConstr = swaggerTypeConstr
412 dataTypeOf = swaggerTypeDataType
485 dataTypeOf = swaggerTypeDataType
413
486
414−instance OVERLAPPABLE_ Data (SwaggerType Schema) where
487+instance Data (SwaggerType 'SwaggerKindSchema) where
415 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
488 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
416 toConstr = swaggerTypeConstr
489 toConstr = swaggerTypeConstr
417 dataTypeOf = swaggerTypeDataType
490 dataTypeOf = swaggerTypeDataType
@@ -451,7 +524,7 @@ data CollectionFormat t where
451 -- Corresponds to multiple parameter instances
524 -- Corresponds to multiple parameter instances
452 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
525 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
453 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
526 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
454− CollectionMulti :: CollectionFormat ParamOtherSchema
527+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
455 deriving (Typeable)
528 deriving (Typeable)
456
529
457deriving instance Eq (CollectionFormat t)
530deriving instance Eq (CollectionFormat t)
@@ -467,12 +540,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
467collectionCommonFormats :: [CollectionFormat t]
540collectionCommonFormats :: [CollectionFormat t]
468collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
541collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
469
542
470−instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
543+instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
471 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
544 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
472 toConstr = collectionFormatConstr
545 toConstr = collectionFormatConstr
473 dataTypeOf _ = collectionFormatDataType
546 dataTypeOf _ = collectionFormatDataType
474
547
475−deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
548+deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
476
549
477type ParamName = Text
550type ParamName = Text
478
551
@@ -482,7 +555,7 @@ data Schema = Schema
482 , _schemaRequired :: [ParamName]
555 , _schemaRequired :: [ParamName]
483
556
484 , _schemaAllOf :: Maybe [Schema]
557 , _schemaAllOf :: Maybe [Schema]
485− , _schemaProperties :: HashMap Text (Referenced Schema)
558+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
486 , _schemaAdditionalProperties :: Maybe (Referenced Schema)
559 , _schemaAdditionalProperties :: Maybe (Referenced Schema)
487
560
488 , _schemaDiscriminator :: Maybe Text
561 , _schemaDiscriminator :: Maybe Text
@@ -494,7 +567,7 @@ data Schema = Schema
494 , _schemaMaxProperties :: Maybe Integer
567 , _schemaMaxProperties :: Maybe Integer
495 , _schemaMinProperties :: Maybe Integer
568 , _schemaMinProperties :: Maybe Integer
496
569
497− , _schemaParamSchema :: ParamSchema Schema
570+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
498 } deriving (Eq, Show, Generic, Data, Typeable)
571 } deriving (Eq, Show, Generic, Data, Typeable)
499
572
500-- | A @'Schema'@ with an optional name.
573-- | A @'Schema'@ with an optional name.
@@ -507,7 +580,7 @@ data NamedSchema = NamedSchema
507-- | Regex pattern for @string@ type.
580-- | Regex pattern for @string@ type.
508type Pattern = Text
581type Pattern = Text
509
582
510−data ParamSchema t = ParamSchema
583+data ParamSchema (t :: SwaggerKind *) = ParamSchema
511 { -- | Declares the value of the parameter that the server will use if none is provided,
584 { -- | Declares the value of the parameter that the server will use if none is provided,
512 -- for example a @"count"@ to control the number of results per page might default to @100@
585 -- for example a @"count"@ to control the number of results per page might default to @100@
513 -- if not supplied by the client in the request.
586 -- if not supplied by the client in the request.
@@ -532,7 +605,7 @@ data ParamSchema t = ParamSchema
532 , _paramSchemaMultipleOf :: Maybe Scientific
605 , _paramSchemaMultipleOf :: Maybe Scientific
533 } deriving (Eq, Show, Generic, Typeable)
606 } deriving (Eq, Show, Generic, Typeable)
534
607
535−deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
608+deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
536
609
537data Xml = Xml
610data Xml = Xml
538 { -- | Replaces the name of the element/attribute used for the described schema property.
611 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -574,7 +647,7 @@ data Responses = Responses
574
647
575 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
648 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
576 -- Describes the expected response for those HTTP status codes.
649 -- Describes the expected response for those HTTP status codes.
577− , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
650+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
578 } deriving (Eq, Show, Generic, Data, Typeable)
651 } deriving (Eq, Show, Generic, Data, Typeable)
579
652
580type HttpStatusCode = Int
653type HttpStatusCode = Int
@@ -593,7 +666,7 @@ data Response = Response
593 , _responseSchema :: Maybe (Referenced Schema)
666 , _responseSchema :: Maybe (Referenced Schema)
594
667
595 -- | A list of headers that are sent with the response.
668 -- | A list of headers that are sent with the response.
596− , _responseHeaders :: HashMap HeaderName Header
669+ , _responseHeaders :: InsOrdHashMap HeaderName Header
597
670
598 -- | An example of the response message.
671 -- | An example of the response message.
599 , _responseExamples :: Maybe Example
672 , _responseExamples :: Maybe Example
@@ -608,7 +681,7 @@ data Header = Header
608 { -- | A short description of the header.
681 { -- | A short description of the header.
609 _headerDescription :: Maybe Text
682 _headerDescription :: Maybe Text
610
683
611− , _headerParamSchema :: ParamSchema Header
684+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
612 } deriving (Eq, Show, Generic, Data, Typeable)
685 } deriving (Eq, Show, Generic, Data, Typeable)
613
686
614data Example = Example { getExample :: Map MediaType Value }
687data Example = Example { getExample :: Map MediaType Value }
@@ -659,7 +732,7 @@ data OAuth2Params = OAuth2Params
659 _oauth2Flow :: OAuth2Flow
732 _oauth2Flow :: OAuth2Flow
660
733
661 -- | The available scopes for the OAuth2 security scheme.
734 -- | The available scopes for the OAuth2 security scheme.
662− , _oauth2Scopes :: HashMap Text Text
735+ , _oauth2Scopes :: InsOrdHashMap Text Text
663 } deriving (Eq, Show, Generic, Data, Typeable)
736 } deriving (Eq, Show, Generic, Data, Typeable)
664
737
665data SecuritySchemeType
738data SecuritySchemeType
@@ -680,7 +753,7 @@ data SecurityScheme = SecurityScheme
680-- The object can have multiple security schemes declared in it which are all required
753-- The object can have multiple security schemes declared in it which are all required
681-- (that is, there is a logical AND between the schemes).
754-- (that is, there is a logical AND between the schemes).
682newtype SecurityRequirement = SecurityRequirement
755newtype SecurityRequirement = SecurityRequirement
683− { getSecurityRequirement :: HashMap Text [Text]
756+ { getSecurityRequirement :: InsOrdHashMap Text [Text]
684 } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
757 } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
685
758
686-- | Tag name.
759-- | Tag name.
@@ -814,9 +887,9 @@ instance SwaggerMonoid ParamLocation where
814 swaggerMempty = ParamQuery
887 swaggerMempty = ParamQuery
815 swaggerMappend _ y = y
888 swaggerMappend _ y = y
816
889
817−instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
890+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
818− swaggerMempty = HashMap.empty
891+ swaggerMempty = InsOrdHashMap.empty
819− swaggerMappend = HashMap.unionWith mappend
892+ swaggerMappend = InsOrdHashMap.unionWith mappend
820
893
821instance Monoid a => SwaggerMonoid (Referenced a) where
894instance Monoid a => SwaggerMonoid (Referenced a) where
822 swaggerMempty = Inline mempty
895 swaggerMempty = Inline mempty
@@ -914,7 +987,8 @@ instance ToJSON OAuth2Flow where
914 , "tokenUrl" .= tokenUrl ]
987 , "tokenUrl" .= tokenUrl ]
915
988
916instance ToJSON OAuth2Params where
989instance ToJSON OAuth2Params where
917− toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
990+ toJSON = sopSwaggerGenericToJSON
991+ DEFINE_TOENCODING
918
992
919instance ToJSON SecuritySchemeType where
993instance ToJSON SecuritySchemeType where
920 toJSON SecuritySchemeBasic
994 toJSON SecuritySchemeBasic
@@ -927,24 +1001,22 @@ instance ToJSON SecuritySchemeType where
927 <+> object [ "type" .= ("oauth2" :: Text) ]
1001 <+> object [ "type" .= ("oauth2" :: Text) ]
928
1002
929instance ToJSON Swagger where
1003instance ToJSON Swagger where
930− toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
1004+ toJSON = sopSwaggerGenericToJSON
931− where
1005+ DEFINE_TOENCODING
932− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
933− addVersion _ = error "impossible"
934
1006
935instance ToJSON SecurityScheme where
1007instance ToJSON SecurityScheme where
936− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1008+ toJSON = sopSwaggerGenericToJSON
1009+ DEFINE_TOENCODING
937
1010
938instance ToJSON Schema where
1011instance ToJSON Schema where
939− toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
1012+ toJSON = sopSwaggerGenericToJSON
940− where
1013+ DEFINE_TOENCODING
941− f "items" (Array _) = True
942− f _ _ = False
943
1014
944instance ToJSON Header where
1015instance ToJSON Header where
945− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
1016+ toJSON = sopSwaggerGenericToJSON
1017+ DEFINE_TOENCODING
946
1018
947−instance ToJSON (SwaggerItems t) where
1019+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
948 toJSON (SwaggerItemsPrimitive fmt schema) = object
1020 toJSON (SwaggerItemsPrimitive fmt schema) = object
949 [ "collectionFormat" .= fmt
1021 [ "collectionFormat" .= fmt
950 , "items" .= schema ]
1022 , "items" .= schema ]
@@ -961,27 +1033,32 @@ instance ToJSON MimeList where
961 toJSON (MimeList xs) = toJSON (map show xs)
1033 toJSON (MimeList xs) = toJSON (map show xs)
962
1034
963instance ToJSON Param where
1035instance ToJSON Param where
964− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1036+ toJSON = sopSwaggerGenericToJSON
1037+ DEFINE_TOENCODING
965
1038
966instance ToJSON ParamAnySchema where
1039instance ToJSON ParamAnySchema where
967 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1040 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
968 toJSON (ParamOther s) = toJSON s
1041 toJSON (ParamOther s) = toJSON s
969
1042
970instance ToJSON ParamOtherSchema where
1043instance ToJSON ParamOtherSchema where
971− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1044+ toJSON = sopSwaggerGenericToJSON
1045+ DEFINE_TOENCODING
972
1046
973instance ToJSON Responses where
1047instance ToJSON Responses where
974− toJSON (Responses def rs) = omitEmpties $
1048+ toJSON = sopSwaggerGenericToJSON
975− toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1049+ DEFINE_TOENCODING
976
1050
977instance ToJSON Response where
1051instance ToJSON Response where
978− toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
1052+ toJSON = sopSwaggerGenericToJSON
1053+ DEFINE_TOENCODING
979
1054
980instance ToJSON Operation where
1055instance ToJSON Operation where
981− toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
1056+ toJSON = sopSwaggerGenericToJSON
1057+ DEFINE_TOENCODING
982
1058
983instance ToJSON PathItem where
1059instance ToJSON PathItem where
984− toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1060+ toJSON = sopSwaggerGenericToJSON
1061+ DEFINE_TOENCODING
985
1062
986instance ToJSON Example where
1063instance ToJSON Example where
987 toJSON = toJSON . Map.mapKeys show . getExample
1064 toJSON = toJSON . Map.mapKeys show . getExample
@@ -1014,11 +1091,10 @@ instance ToJSON (CollectionFormat t) where
1014 toJSON CollectionPipes = "pipes"
1091 toJSON CollectionPipes = "pipes"
1015 toJSON CollectionMulti = "multi"
1092 toJSON CollectionMulti = "multi"
1016
1093
1017−instance ToJSON (ParamSchema t) where
1094+instance ToJSON (ParamSchema k) where
1018− toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1095+ -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1019− where
1096+ toJSON = sopSwaggerGenericToJSONWithOpts $
1020− f "items" (Array _) = True
1097+ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1021− f _ _ = False
1022
1098
1023-- =======================================================================
1099-- =======================================================================
1024-- Manual FromJSON instances
1100-- Manual FromJSON instances
@@ -1038,7 +1114,7 @@ instance FromJSON OAuth2Flow where
1038 parseJSON _ = empty
1114 parseJSON _ = empty
1039
1115
1040instance FromJSON OAuth2Params where
1116instance FromJSON OAuth2Params where
1041− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1117+ parseJSON = sopSwaggerGenericParseJSON
1042
1118
1043instance FromJSON SecuritySchemeType where
1119instance FromJSON SecuritySchemeType where
1044 parseJSON js@(Object o) = do
1120 parseJSON js@(Object o) = do
@@ -1051,38 +1127,28 @@ instance FromJSON SecuritySchemeType where
1051 parseJSON _ = empty
1127 parseJSON _ = empty
1052
1128
1053instance FromJSON Swagger where
1129instance FromJSON Swagger where
1054− parseJSON js@(Object o) = do
1130+ parseJSON = sopSwaggerGenericParseJSON
1055− (version :: Text) <- o .: "swagger"
1056− when (version /= "2.0") empty
1057− (genericParseJSON (jsonPrefix "swagger")
1058− `withDefaults` [ "consumes" .= (mempty :: MimeList)
1059− , "produces" .= (mempty :: MimeList)
1060− , "security" .= ([] :: [SecurityRequirement])
1061− , "tags" .= ([] :: [Tag])
1062− , "definitions" .= (mempty :: Definitions Schema)
1063− , "parameters" .= (mempty :: Definitions Param)
1064− , "responses" .= (mempty :: Definitions Response)
1065− , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1066− ] ) js
1067− parseJSON _ = empty
1068
1131
1069instance FromJSON SecurityScheme where
1132instance FromJSON SecurityScheme where
1070− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1133+ parseJSON = sopSwaggerGenericParseJSON
1071
1134
1072instance FromJSON Schema where
1135instance FromJSON Schema where
1073− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1136+ parseJSON = sopSwaggerGenericParseJSON
1074− `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1075− , "required" .= ([] :: [ParamName]) ]
1076
1137
1077instance FromJSON Header where
1138instance FromJSON Header where
1078− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1139+ parseJSON = sopSwaggerGenericParseJSON
1079
1140
1080−instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1141+instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1081 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1142 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1082 <$> o .:? "collectionFormat"
1143 <$> o .:? "collectionFormat"
1083 <*> (o .: "items" >>= parseJSON)
1144 <*> (o .: "items" >>= parseJSON)
1084
1145
1146+instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1147+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1148+ <$> o .:? "collectionFormat"
1149+ <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1150+
1085−instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1151+instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1086 parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1152 parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1087 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1153 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1088 parseJSON _ = empty
1154 parseJSON _ = empty
@@ -1100,7 +1166,7 @@ instance FromJSON MimeList where
1100 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1166 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1101
1167
1102instance FromJSON Param where
1168instance FromJSON Param where
1103− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1169+ parseJSON = sopSwaggerGenericParseJSON
1104
1170
1105instance FromJSON ParamAnySchema where
1171instance FromJSON ParamAnySchema where
1106 parseJSON js@(Object o) = do
1172 parseJSON js@(Object o) = do
@@ -1113,12 +1179,12 @@ instance FromJSON ParamAnySchema where
1113 parseJSON _ = empty
1179 parseJSON _ = empty
1114
1180
1115instance FromJSON ParamOtherSchema where
1181instance FromJSON ParamOtherSchema where
1116− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1182+ parseJSON = sopSwaggerGenericParseJSON
1117
1183
1118instance FromJSON Responses where
1184instance FromJSON Responses where
1119 parseJSON (Object o) = Responses
1185 parseJSON (Object o) = Responses
1120 <$> o .:? "default"
1186 <$> o .:? "default"
1121− <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1187+ <*> (parseJSON (Object (HashMap.delete "default" o)))
1122 parseJSON _ = empty
1188 parseJSON _ = empty
1123
1189
1124instance FromJSON Example where
1190instance FromJSON Example where
@@ -1127,18 +1193,13 @@ instance FromJSON Example where
1127 pure $ Example (Map.mapKeys fromString m)
1193 pure $ Example (Map.mapKeys fromString m)
1128
1194
1129instance FromJSON Response where
1195instance FromJSON Response where
1130− parseJSON = genericParseJSON (jsonPrefix "response")
1196+ parseJSON = sopSwaggerGenericParseJSON
1131− `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1132
1197
1133instance FromJSON Operation where
1198instance FromJSON Operation where
1134− parseJSON = genericParseJSON (jsonPrefix "operation")
1199+ parseJSON = sopSwaggerGenericParseJSON
1135− `withDefaults` [ "security" .= ([] :: [SecurityRequirement])
1136− , "tags" .= ([] :: [Tag])
1137− , "parameters" .= ([] :: [Referenced Param]) ]
1138
1200
1139instance FromJSON PathItem where
1201instance FromJSON PathItem where
1140− parseJSON = genericParseJSON (jsonPrefix "pathItem")
1202+ parseJSON = sopSwaggerGenericParseJSON
1141− `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1142
1203
1143instance FromJSON Reference where
1204instance FromJSON Reference where
1144 parseJSON (Object o) = Reference <$> o .: "$ref"
1205 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1164,26 +1225,86 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
1164instance FromJSON Xml where
1225instance FromJSON Xml where
1165 parseJSON = genericParseJSON (jsonPrefix "xml")
1226 parseJSON = genericParseJSON (jsonPrefix "xml")
1166
1227
1167−instance FromJSON (SwaggerType Schema) where
1228+instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1168 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1229 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1169
1230
1170−instance FromJSON (SwaggerType ParamOtherSchema) where
1231+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1171 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1232 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1172
1233
1173−instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
1234+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1174 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1235 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1175
1236
1176−instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
1237+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1177 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1238 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1178
1239
1240+-- NOTE: There aren't collections of 'Schema'
1179−instance FromJSON (CollectionFormat ParamOtherSchema) where
1241+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1180− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1242+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1181
1243
1182−-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1244+instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1183−-- @FromJSON (SwaggerItems t)@ are necessary here!
1245+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1184−-- Without the constraint the general instance will be used
1185−-- that only accepts common types (i.e. NOT object, null or file)
1186−-- and primitive array items.
1187−instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1188− parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1189
1246
1247+instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1248+ parseJSON = sopSwaggerGenericParseJSON
1249+instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1250+ parseJSON = sopSwaggerGenericParseJSON
1251+instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1252+ parseJSON = sopSwaggerGenericParseJSON
1253+
1254+-------------------------------------------------------------------------------
1255+-- TH splices
1256+-------------------------------------------------------------------------------
1257+
1258+deriveGeneric ''Header
1259+deriveGeneric ''OAuth2Params
1260+deriveGeneric ''Operation
1261+deriveGeneric ''Param
1262+deriveGeneric ''ParamOtherSchema
1263+deriveGeneric ''PathItem
1264+deriveGeneric ''Response
1265+deriveGeneric ''Responses
1266+deriveGeneric ''SecurityScheme
1267+deriveGeneric ''Schema
1268+deriveGeneric ''ParamSchema
1269+deriveGeneric ''Swagger
1270+
1271+instance HasSwaggerAesonOptions Header where
1272+ swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1273+instance HasSwaggerAesonOptions OAuth2Params where
1274+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1275+instance HasSwaggerAesonOptions Operation where
1276+ swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1277+instance HasSwaggerAesonOptions Param where
1278+ swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1279+instance HasSwaggerAesonOptions ParamOtherSchema where
1280+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1281+instance HasSwaggerAesonOptions PathItem where
1282+ swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1283+instance HasSwaggerAesonOptions Response where
1284+ swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1285+instance HasSwaggerAesonOptions Responses where
1286+ swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1287+instance HasSwaggerAesonOptions SecurityScheme where
1288+ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1289+instance HasSwaggerAesonOptions Schema where
1290+ swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1291+instance HasSwaggerAesonOptions Swagger where
1292+ swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1293+
1294+instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where
1295+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1296+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where
1297+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1298+-- NOTE: Schema doesn't have 'items' sub object!
1299+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where
1300+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1301+
1302+instance AesonDefaultValue (ParamSchema s)
1303+instance AesonDefaultValue OAuth2Flow
1304+instance AesonDefaultValue Responses
1305+instance AesonDefaultValue ParamAnySchema
1306+instance AesonDefaultValue SecuritySchemeType
1307+instance AesonDefaultValue (SwaggerType a)
1308+instance AesonDefaultValue MimeList where defaultValue = Just mempty
1309+instance AesonDefaultValue Info
1310+instance AesonDefaultValue ParamLocation
src/Data/Swagger/Internal/AesonUtils.hsnew file+333
@@ -0,0 +1,333 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE ExplicitForAll #-}
7+{-# LANGUAGE TemplateHaskell #-}
8+module Data.Swagger.Internal.AesonUtils (
9+ -- * Generic functions
10+ AesonDefaultValue(..),
11+ sopSwaggerGenericToJSON,
12+#if MIN_VERSION_aeson(0,10,0)
13+ sopSwaggerGenericToEncoding,
14+#endif
15+ sopSwaggerGenericToJSONWithOpts,
16+ sopSwaggerGenericParseJSON,
17+ -- * Options
18+ HasSwaggerAesonOptions(..),
19+ SwaggerAesonOptions,
20+ mkSwaggerAesonOptions,
21+ saoPrefix,
22+ saoAdditionalPairs,
23+ saoSubObject,
24+ ) where
25+
26+import Prelude ()
27+import Prelude.Compat
28+
29+import Control.Applicative ((<|>))
30+import Control.Lens (makeLenses, (^.))
31+import Control.Monad (unless)
32+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
33+import Data.Aeson.Types (Parser, Pair)
34+import Data.Char (toLower, isUpper)
35+import Data.Foldable (traverse_)
36+import Data.Text (Text)
37+
38+import Generics.SOP
39+
40+import qualified Data.Text as T
41+import qualified Data.HashMap.Strict as HM
42+import qualified Data.Set as Set
43+import qualified Data.HashMap.Strict.InsOrd as InsOrd
44+
45+#if MIN_VERSION_aeson(0,10,0)
46+import Data.Aeson (Encoding, pairs, (.=), Series)
47+import Data.Monoid ((<>))
48+#endif
49+
50+-------------------------------------------------------------------------------
51+-- SwaggerAesonOptions
52+-------------------------------------------------------------------------------
53+
54+data SwaggerAesonOptions = SwaggerAesonOptions
55+ { _saoPrefix :: String
56+ , _saoAdditionalPairs :: [(Text, Value)]
57+ , _saoSubObject :: Maybe String
58+ }
59+
60+mkSwaggerAesonOptions
61+ :: String -- ^ prefix
62+ -> SwaggerAesonOptions
63+mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
64+
65+makeLenses ''SwaggerAesonOptions
66+
67+class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
68+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions
69+
70+ -- So far we use only default definitions
71+ aesonDefaults :: proxy a -> POP Maybe (Code a)
72+ aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
73+
74+-------------------------------------------------------------------------------
75+-- Generics
76+-------------------------------------------------------------------------------
77+
78+class AesonDefaultValue a where
79+ defaultValue :: Maybe a
80+ defaultValue = Nothing
81+
82+instance AesonDefaultValue Text where defaultValue = Nothing
83+instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
84+instance AesonDefaultValue [a] where defaultValue = Just []
85+instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
86+instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
87+
88+-------------------------------------------------------------------------------
89+-- ToJSON
90+-------------------------------------------------------------------------------
91+
92+-- | Generic serialisation for swagger records.
93+--
94+-- Features
95+--
96+-- * omits nulls, empty objects and empty arrays (configurable)
97+-- * possible to add fields
98+-- * possible to merge sub-object
99+sopSwaggerGenericToJSON
100+ :: forall a xs.
101+ ( Generic a
102+ , HasDatatypeInfo a
103+ , HasSwaggerAesonOptions a
104+ , All2 ToJSON (Code a)
105+ , All2 Eq (Code a)
106+ , Code a ~ '[xs]
107+ )
108+ => a
109+ -> Value
110+sopSwaggerGenericToJSON x =
111+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
112+ in object (opts ^. saoAdditionalPairs ++ ps)
113+ where
114+ proxy = Proxy :: Proxy a
115+ opts = swaggerAesonOptions proxy
116+
117+-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
118+--
119+-- Also uses default `aesonDefaults`
120+sopSwaggerGenericToJSONWithOpts
121+ :: forall a xs.
122+ ( Generic a
123+ , All2 AesonDefaultValue (Code a)
124+ , HasDatatypeInfo a
125+ , All2 ToJSON (Code a)
126+ , All2 Eq (Code a)
127+ , Code a ~ '[xs]
128+ )
129+ => SwaggerAesonOptions
130+ -> a
131+ -> Value
132+sopSwaggerGenericToJSONWithOpts opts x =
133+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
134+ in object (opts ^. saoAdditionalPairs ++ ps)
135+ where
136+ proxy = Proxy :: Proxy a
137+ defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
138+
139+sopSwaggerGenericToJSON'
140+ :: (All2 ToJSON '[xs], All2 Eq '[xs])
141+ => SwaggerAesonOptions
142+ -> SOP I '[xs]
143+ -> DatatypeInfo '[xs]
144+ -> POP Maybe '[xs]
145+ -> [Pair]
146+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
147+ sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
148+sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
149+
150+sopSwaggerGenericToJSON''
151+ :: (All ToJSON xs, All Eq xs)
152+ => SwaggerAesonOptions
153+ -> NP I xs
154+ -> NP FieldInfo xs
155+ -> NP Maybe xs
156+ -> [Pair]
157+sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
158+ where
159+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
160+ go Nil Nil Nil = []
161+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)
162+ | Just name' == sub = case json of
163+ Object m -> HM.toList m ++ rest
164+ Null -> rest
165+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
166+ -- If default value: omit it.
167+ | Just x == def =
168+ rest
169+ | otherwise =
170+ (T.pack name', json) : rest
171+ where
172+ json = toJSON x
173+ name' = fieldNameModifier name
174+ rest = go xs names defs
175+#if __GLASGOW_HASKELL__ < 800
176+ go _ _ _ = error "not empty"
177+#endif
178+
179+ fieldNameModifier = modifier . drop 1
180+ modifier = lowerFirstUppers . drop (length prefix)
181+ lowerFirstUppers s = map toLower x ++ y
182+ where (x, y) = span isUpper s
183+
184+-------------------------------------------------------------------------------
185+-- FromJSON
186+-------------------------------------------------------------------------------
187+
188+sopSwaggerGenericParseJSON
189+ :: forall a xs.
190+ ( Generic a
191+ , HasDatatypeInfo a
192+ , HasSwaggerAesonOptions a
193+ , All2 FromJSON (Code a)
194+ , All2 Eq (Code a)
195+ , Code a ~ '[xs]
196+ )
197+ => Value
198+ -> Parser a
199+sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
200+ let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
201+ in do
202+ traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
203+ to <$> ps
204+ where
205+ proxy = Proxy :: Proxy a
206+ opts = swaggerAesonOptions proxy
207+
208+ parseAdditionalField :: Object -> (Text, Value) -> Parser ()
209+ parseAdditionalField obj (k, v) = do
210+ v' <- obj .: k
211+ unless (v == v') $ fail $
212+ "Additonal field don't match for key " ++ T.unpack k
213+ ++ ": " ++ show v
214+ ++ " /= " ++ show v'
215+
216+sopSwaggerGenericParseJSON'
217+ :: (All2 FromJSON '[xs], All2 Eq '[xs])
218+ => SwaggerAesonOptions
219+ -> Object
220+ -> DatatypeInfo '[xs]
221+ -> POP Maybe '[xs]
222+ -> Parser (SOP I '[xs])
223+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
224+ SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
225+sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
226+
227+sopSwaggerGenericParseJSON''
228+ :: (All FromJSON xs, All Eq xs)
229+ => SwaggerAesonOptions
230+ -> Object
231+ -> NP FieldInfo xs
232+ -> NP Maybe xs
233+ -> Parser (NP I xs)
234+sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
235+ where
236+ go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
237+ go Nil Nil = pure Nil
238+ go (FieldInfo name :* names) (def :* defs)
239+ | Just name' == sub =
240+ -- Note: we might strip fields of outer structure.
241+ cons <$> (withDef $ parseJSON $ Object obj) <*> rest
242+ | otherwise = case def of
243+ Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
244+ Nothing -> cons <$> obj .: T.pack name' <*> rest
245+ where
246+ cons h t = I h :* t
247+ name' = fieldNameModifier name
248+ rest = go names defs
249+
250+ withDef = case def of
251+ Just def' -> (<|> pure def')
252+ Nothing -> id
253+#if __GLASGOW_HASKELL__ < 800
254+ go _ _ = error "not empty"
255+#endif
256+
257+ fieldNameModifier = modifier . drop 1
258+ modifier = lowerFirstUppers . drop (length prefix)
259+ lowerFirstUppers s = map toLower x ++ y
260+ where (x, y) = span isUpper s
261+
262+-------------------------------------------------------------------------------
263+-- ToEncoding
264+-------------------------------------------------------------------------------
265+
266+#if MIN_VERSION_aeson(0,10,0)
267+
268+sopSwaggerGenericToEncoding
269+ :: forall a xs.
270+ ( Generic a
271+ , HasDatatypeInfo a
272+ , HasSwaggerAesonOptions a
273+ , All2 ToJSON (Code a)
274+ , All2 Eq (Code a)
275+ , Code a ~ '[xs]
276+ )
277+ => a
278+ -> Encoding
279+sopSwaggerGenericToEncoding x =
280+ let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
281+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
282+ where
283+ proxy = Proxy :: Proxy a
284+ opts = swaggerAesonOptions proxy
285+
286+pairsToSeries :: [Pair] -> Series
287+pairsToSeries = foldMap (\(k, v) -> (k .= v))
288+
289+sopSwaggerGenericToEncoding'
290+ :: (All2 ToJSON '[xs], All2 Eq '[xs])
291+ => SwaggerAesonOptions
292+ -> SOP I '[xs]
293+ -> DatatypeInfo '[xs]
294+ -> POP Maybe '[xs]
295+ -> Series
296+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
297+ sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
298+sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
299+
300+sopSwaggerGenericToEncoding''
301+ :: (All ToJSON xs, All Eq xs)
302+ => SwaggerAesonOptions
303+ -> NP I xs
304+ -> NP FieldInfo xs
305+ -> NP Maybe xs
306+ -> Series
307+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
308+ where
309+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
310+ go Nil Nil Nil = mempty
311+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)
312+ | Just name' == sub = case toJSON x of
313+ Object m -> pairsToSeries (HM.toList m) <> rest
314+ Null -> rest
315+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
316+ -- If default value: omit it.
317+ | Just x == def =
318+ rest
319+ | otherwise =
320+ (T.pack name' .= x) <> rest
321+ where
322+ name' = fieldNameModifier name
323+ rest = go xs names defs
324+#if __GLASGOW_HASKELL__ < 800
325+ go _ _ _ = error "not empty"
326+#endif
327+
328+ fieldNameModifier = modifier . drop 1
329+ modifier = lowerFirstUppers . drop (length prefix)
330+ lowerFirstUppers s = map toLower x ++ y
331+ where (x, y) = span isUpper s
332+
333+#endif
src/Data/Swagger/Internal/Schema.hs+20−16
@@ -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 #-}
@@ -25,6 +26,7 @@ import Control.Applicative
25import Control.Monad
26import Control.Monad
26import Control.Monad.Writer
27import Control.Monad.Writer
27import Data.Aeson
28import Data.Aeson
29+import qualified Data.Aeson.Types as Aeson
28import Data.Char
30import Data.Char
29import Data.Data (Data)
31import Data.Data (Data)
30import Data.Foldable (traverse_)
32import Data.Foldable (traverse_)
@@ -33,6 +35,8 @@ import Data.HashMap.Strict (HashMap)
33import qualified Data.HashMap.Strict as HashMap
35import qualified Data.HashMap.Strict as HashMap
34import "unordered-containers" Data.HashSet (HashSet)
36import "unordered-containers" Data.HashSet (HashSet)
35import qualified "unordered-containers" Data.HashSet as HashSet
37import qualified "unordered-containers" Data.HashSet as HashSet
38+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
39+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
36import Data.Int
40import Data.Int
37import Data.IntSet (IntSet)
41import Data.IntSet (IntSet)
38import Data.IntMap (IntMap)
42import Data.IntMap (IntMap)
@@ -194,7 +198,7 @@ declareSchemaRef proxy = do
194 -- have already declared it.
198 -- have already declared it.
195 -- If we have, we don't need to declare anything for
199 -- If we have, we don't need to declare anything for
196 -- this schema this time and thus simply return the reference.
200 -- this schema this time and thus simply return the reference.
197− known <- looks (HashMap.member name)
201+ known <- looks (InsOrdHashMap.member name)
198 when (not known) $ do
202 when (not known) $ do
199 declare [(name, schema)]
203 declare [(name, schema)]
200 void $ declareNamedSchema proxy
204 void $ declareNamedSchema proxy
@@ -213,7 +217,7 @@ inlineSchemasWhen p defs = template %~ deref
213 where
217 where
214 deref r@(Ref (Reference name))
218 deref r@(Ref (Reference name))
215 | p name =
219 | p name =
216− case HashMap.lookup name defs of
220+ case InsOrdHashMap.lookup name defs of
217 Just schema -> Inline (inlineSchemasWhen p defs schema)
221 Just schema -> Inline (inlineSchemasWhen p defs schema)
218 Nothing -> r
222 Nothing -> r
219 | otherwise = r
223 | otherwise = r
@@ -255,7 +259,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
255inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
259inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
256 where
260 where
257 nonRecursive name =
261 nonRecursive name =
258− case HashMap.lookup name defs of
262+ case InsOrdHashMap.lookup name defs of
259 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
263 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
260 Nothing -> False
264 Nothing -> False
261
265
@@ -267,7 +271,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
267 seen <- looks (name `elem`)
271 seen <- looks (name `elem`)
268 when (not seen) $ do
272 when (not seen) $ do
269 declare [name]
273 declare [name]
270− traverse_ usedNames (HashMap.lookup name defs)
274+ traverse_ usedNames (InsOrdHashMap.lookup name defs)
271 Inline subschema -> usedNames subschema
275 Inline subschema -> usedNames subschema
272
276
273-- | Default schema for binary data (any sequence of octets).
277-- | Default schema for binary data (any sequence of octets).
@@ -304,7 +308,7 @@ passwordSchema = mempty
304-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
308-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
305-- >>> instance ToJSON Person
309-- >>> instance ToJSON Person
306-- >>> encode $ sketchSchema (Person "Jack" 25)
310-- >>> encode $ sketchSchema (Person "Jack" 25)
307−-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"
311+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
308sketchSchema :: ToJSON a => a -> Schema
312sketchSchema :: ToJSON a => a -> Schema
309sketchSchema = sketch . toJSON
313sketchSchema = sketch . toJSON
310 where
314 where
@@ -331,7 +335,7 @@ sketchSchema = sketch . toJSON
331 go js@(Object o) = mempty
335 go js@(Object o) = mempty
332 & type_ .~ SwaggerObject
336 & type_ .~ SwaggerObject
333 & required .~ HashMap.keys o
337 & required .~ HashMap.keys o
334− & properties .~ fmap (Inline . go) o
338+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
335
339
336-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
340-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
337-- Produced schema uses as much constraints as possible.
341-- Produced schema uses as much constraints as possible.
@@ -348,7 +352,7 @@ sketchSchema = sketch . toJSON
348-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
352-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
349-- >>> instance ToJSON Person
353-- >>> instance ToJSON Person
350-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
354-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
351−-- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"
355+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"
352sketchStrictSchema :: ToJSON a => a -> Schema
356sketchStrictSchema :: ToJSON a => a -> Schema
353sketchStrictSchema = go . toJSON
357sketchStrictSchema = go . toJSON
354 where
358 where
@@ -381,7 +385,7 @@ sketchStrictSchema = go . toJSON
381 go js@(Object o) = mempty
385 go js@(Object o) = mempty
382 & type_ .~ SwaggerObject
386 & type_ .~ SwaggerObject
383 & required .~ names
387 & required .~ names
384− & properties .~ fmap (Inline . go) o
388+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
385 & maxProperties ?~ fromIntegral (length names)
389 & maxProperties ?~ fromIntegral (length names)
386 & minProperties ?~ fromIntegral (length names)
390 & minProperties ?~ fromIntegral (length names)
387 & enum_ ?~ [js]
391 & enum_ ?~ [js]
@@ -564,8 +568,8 @@ gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts prox
564
568
565instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
569instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
566 gdeclareNamedSchema opts _ schema = do
570 gdeclareNamedSchema opts _ schema = do
567− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
571+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
568− gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
572+ gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
569
573
570instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
574instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
571 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
575 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
@@ -605,16 +609,16 @@ gdeclareSchemaRef opts proxy = do
605 -- have already declared it.
609 -- have already declared it.
606 -- If we have, we don't need to declare anything for
610 -- If we have, we don't need to declare anything for
607 -- this schema this time and thus simply return the reference.
611 -- this schema this time and thus simply return the reference.
608− known <- looks (HashMap.member name)
612+ known <- looks (InsOrdHashMap.member name)
609 when (not known) $ do
613 when (not known) $ do
610 declare [(name, schema)]
614 declare [(name, schema)]
611 void $ gdeclareNamedSchema opts proxy mempty
615 void $ gdeclareNamedSchema opts proxy mempty
612 return $ Ref (Reference name)
616 return $ Ref (Reference name)
613 _ -> Inline <$> gdeclareSchema opts proxy
617 _ -> Inline <$> gdeclareSchema opts proxy
614
618
615−appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
619+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)
616appendItem x Nothing = Just (SwaggerItemsArray [x])
620appendItem x Nothing = Just (SwaggerItemsArray [x])
617−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
621+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
618appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
622appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
619
623
620withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
624withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
@@ -630,7 +634,7 @@ withFieldSchema opts _ isRequiredField schema = do
630 & type_ .~ SwaggerObject
634 & type_ .~ SwaggerObject
631 & properties . at fname ?~ ref
635 & properties . at fname ?~ ref
632 & if isRequiredField
636 & if isRequiredField
633− then required %~ (fname :)
637+ then required %~ (++ [fname])
634 else id
638 else id
635 where
639 where
636 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
640 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
@@ -662,7 +666,7 @@ gdeclareNamedSumSchema opts proxy s
662
666
663 toStringTag schema = mempty
667 toStringTag schema = mempty
664 & type_ .~ SwaggerString
668 & type_ .~ SwaggerString
665− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
669+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
666
670
667type AllNullary = All
671type AllNullary = All
668
672
@@ -670,7 +674,7 @@ class GSumToSchema f where
670 gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
674 gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
671
675
672instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
676instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
673− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
677+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
674
678
675gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
679gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
676 Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
680 Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
src/Data/Swagger/Internal/Schema/Validation.hs+4−2
@@ -30,6 +30,8 @@ import Data.Foldable (traverse_, for_, sequenceA_)
30import Data.HashMap.Strict (HashMap)
30import Data.HashMap.Strict (HashMap)
31import qualified Data.HashMap.Strict as HashMap
31import qualified Data.HashMap.Strict as HashMap
32import qualified "unordered-containers" Data.HashSet as HashSet
32import qualified "unordered-containers" Data.HashSet as HashSet
33+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
34+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
33import Data.Monoid
35import Data.Monoid
34import Data.Proxy
36import Data.Proxy
35import Data.Scientific (Scientific, isInteger)
37import Data.Scientific (Scientific, isInteger)
@@ -174,7 +176,7 @@ sub_ = lmap . view
174-- | Validate value against a schema given schema reference and validation function.
176-- | Validate value against a schema given schema reference and validation function.
175withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
177withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
176withRef (Reference ref) f = withConfig $ \cfg ->
178withRef (Reference ref) f = withConfig $ \cfg ->
177− case HashMap.lookup ref (configDefinitions cfg) of
179+ case InsOrdHashMap.lookup ref (configDefinitions cfg) of
178 Nothing -> invalid $ "unknown schema " ++ show ref
180 Nothing -> invalid $ "unknown schema " ++ show ref
179 Just s -> f s
181 Just s -> f s
180
182
@@ -290,7 +292,7 @@ validateObject o = withSchema $ \schema ->
290 case v of
292 case v of
291 Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property
293 Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property
292 _ ->
294 _ ->
293− case HashMap.lookup k (schema ^. properties) of
295+ case InsOrdHashMap.lookup k (schema ^. properties) of
294 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v
296 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v
295 Just s -> validateWithSchemaRef s v
297 Just s -> validateWithSchemaRef s v
296
298
src/Data/Swagger/Internal/Utils.hs+6−45
@@ -9,8 +9,6 @@ module Data.Swagger.Internal.Utils where
9import Prelude ()
9import Prelude ()
10import Prelude.Compat
10import Prelude.Compat
11
11
12−import Control.Arrow (first)
13−import Control.Applicative
14import Control.Lens ((&), (%~))
12import Control.Lens ((&), (%~))
15import Control.Lens.TH
13import Control.Lens.TH
16import Data.Aeson
14import Data.Aeson
@@ -20,13 +18,14 @@ import Data.Data
20import Data.Hashable (Hashable)
18import Data.Hashable (Hashable)
21import Data.HashMap.Strict (HashMap)
19import Data.HashMap.Strict (HashMap)
22import qualified Data.HashMap.Strict as HashMap
20import qualified Data.HashMap.Strict as HashMap
21+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23import Data.Map (Map)
23import Data.Map (Map)
24import Data.Monoid
24import Data.Monoid
25import Data.Set (Set)
25import Data.Set (Set)
26import Data.Text (Text)
26import Data.Text (Text)
27import GHC.Generics
27import GHC.Generics
28import Language.Haskell.TH (mkName)
28import Language.Haskell.TH (mkName)
29−import Text.Read (readMaybe)
30
29
31swaggerFieldRules :: LensRules
30swaggerFieldRules :: LensRules
32swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
31swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -53,17 +52,6 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
53 Just x -> z x
52 Just x -> z x
54 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
53 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
55
54
56−hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
57−hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
58−
59−hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
60−hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
61− where
62− g (x, y) = (\a -> (a, y)) <$> f x
63−
64−hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
65−hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
66−
67jsonPrefix :: String -> Options
55jsonPrefix :: String -> Options
68jsonPrefix prefix = defaultOptions
56jsonPrefix prefix = defaultOptions
69 { fieldLabelModifier = modifier . drop 1
57 { fieldLabelModifier = modifier . drop 1
@@ -85,40 +73,10 @@ parseOneOf xs js =
85 where
73 where
86 ys = zip (map toJSON xs) xs
74 ys = zip (map toJSON xs) xs
87
75
88−omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
89−omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
90− where
91− nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
92−omitEmptiesExcept _ js = js
93−
94−omitEmpties :: Value -> Value
95−omitEmpties = omitEmptiesExcept (\_ _ -> False)
96−
97−genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
98−genericToJSONWithSub sub opts x =
99− case genericToJSON opts x of
100− Object o ->
101− case HashMap.lookup sub o of
102− Just so -> Object (HashMap.delete sub o) <+> so
103− Nothing -> Object o -- no subjson, leaving object as is
104− _ -> error "genericToJSONWithSub: subjson is not an object"
105−
106−genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
107−genericParseJSONWithSub sub opts js@(Object o)
108− = genericParseJSON opts js -- try without subjson
109− <|> genericParseJSON opts js' -- try with subjson
110− where
111− js' = Object (HashMap.insert sub (Object o) o)
112−genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
113−
114(<+>) :: Value -> Value -> Value
76(<+>) :: Value -> Value -> Value
115Object x <+> Object y = Object (x <> y)
77Object x <+> Object y = Object (x <> y)
116_ <+> _ = error "<+>: merging non-objects"
78_ <+> _ = error "<+>: merging non-objects"
117
79
118−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
119−withDefaults parser defs js@(Object _) = parser (js <+> object defs)
120−withDefaults _ _ _ = empty
121−
122genericMempty :: (Generic a, GMonoid (Rep a)) => a
80genericMempty :: (Generic a, GMonoid (Rep a)) => a
123genericMempty = to gmempty
81genericMempty = to gmempty
124
82
@@ -161,6 +119,10 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
161 swaggerMempty = mempty
119 swaggerMempty = mempty
162 swaggerMappend = HashMap.unionWith (\_old new -> new)
120 swaggerMappend = HashMap.unionWith (\_old new -> new)
163
121
122+instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
123+ swaggerMempty = mempty
124+ swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
125+
164instance SwaggerMonoid Text where
126instance SwaggerMonoid Text where
165 swaggerMempty = mempty
127 swaggerMempty = mempty
166 swaggerMappend x "" = x
128 swaggerMappend x "" = x
@@ -170,4 +132,3 @@ instance SwaggerMonoid (Maybe a) where
170 swaggerMempty = Nothing
132 swaggerMempty = Nothing
171 swaggerMappend x Nothing = x
133 swaggerMappend x Nothing = x
172 swaggerMappend _ y = y
134 swaggerMappend _ y = y
173−
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_
src/Data/Swagger/Operation.hs+9−8
@@ -46,6 +46,9 @@ import Data.Swagger.Internal
46import Data.Swagger.Lens
46import Data.Swagger.Lens
47import Data.Swagger.Schema
47import Data.Swagger.Schema
48
48
49+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
50+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
51+
49-- $setup
52-- $setup
50-- >>> import Data.Aeson
53-- >>> import Data.Aeson
51-- >>> import Data.Proxy
54-- >>> import Data.Proxy
@@ -58,10 +61,8 @@ import Data.Swagger.Schema
58-- >>> encode $ prependPath "user/{user_id}" api ^. paths
61-- >>> encode $ prependPath "user/{user_id}" api ^. paths
59-- "{\"/user/{user_id}/info\":{}}"
62-- "{\"/user/{user_id}/info\":{}}"
60prependPath :: FilePath -> Swagger -> Swagger
63prependPath :: FilePath -> Swagger -> Swagger
61−prependPath path = paths %~ mapKeys (path </>)
64+prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
62 where
65 where
63− mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
64−
65 x </> y = case trim y of
66 x </> y = case trim y of
66 "" -> "/" <> trim x
67 "" -> "/" <> trim x
67 y' -> "/" <> trim x <> "/" <> y'
68 y' -> "/" <> trim x <> "/" <> y'
@@ -80,15 +81,15 @@ allOperations = paths.traverse.template
80-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82-- >>> encode api
83-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
85-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
85−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
86+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
86operationsOf :: Swagger -> Traversal' Swagger Operation
87operationsOf :: Swagger -> Traversal' Swagger Operation
87operationsOf sub = paths.itraversed.withIndex.subops
88operationsOf sub = paths.itraversed.withIndex.subops
88 where
89 where
89 -- | Traverse operations that correspond to paths and methods of the sub API.
90 -- | Traverse operations that correspond to paths and methods of the sub API.
90 subops :: Traversal' (FilePath, PathItem) Operation
91 subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
92+ subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
92 Just subitem -> (,) path <$> methodsOf subitem f item
93 Just subitem -> (,) path <$> methodsOf subitem f item
93 Nothing -> pure (path, item)
94 Nothing -> pure (path, item)
94
95
@@ -119,7 +120,7 @@ applyTagsFor ops ts swag = swag
119-- necessary schema definitions.
120-- necessary schema definitions.
120--
121--
121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122−-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
123+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
123declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
124declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
124declareResponse proxy = do
125declareResponse proxy = do
125 s <- declareSchemaRef proxy
126 s <- declareSchemaRef proxy
@@ -139,7 +140,7 @@ declareResponse proxy = do
139-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140-- >>> let res = declareResponse (Proxy :: Proxy Day)
141-- >>> let res = declareResponse (Proxy :: Proxy Day)
141-- >>> encode $ api & setResponse 200 res
142-- >>> encode $ api & setResponse 200 res
142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
143+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}}}"
143--
144--
144-- See also @'setResponseWith'@.
145-- See also @'setResponseWith'@.
145setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
146setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
stack-lts-2.yaml+4−1
@@ -1,5 +1,8 @@
1flags: {}
1flags: {}
2packages:
2packages:
3- '.'
3- '.'
4−extra-deps: []
4+extra-deps:
5+- generics-sop-0.2.1.0
6+- insert-ordered-containers-0.1.0.1
7+- unordered-containers-0.2.7.0
5resolver: lts-2.22
8resolver: lts-2.22
stack.yaml+4−2
@@ -1,5 +1,7 @@
1flags: {}
1flags: {}
2packages:
2packages:
3- '.'
3- '.'
4−extra-deps: []
4+extra-deps:
5+- aeson-0.11.1.0
6+- insert-ordered-containers-0.1.0.1
5−resolver: nightly-2016-01-26
7+resolver: nightly-2016-03-04
swagger2.cabal+7−1
@@ -38,12 +38,15 @@ library
38 Data.Swagger.Internal.Schema.Validation
38 Data.Swagger.Internal.Schema.Validation
39 Data.Swagger.Internal.ParamSchema
39 Data.Swagger.Internal.ParamSchema
40 Data.Swagger.Internal.Utils
40 Data.Swagger.Internal.Utils
41+ Data.Swagger.Internal.AesonUtils
41 build-depends: base >=4.7 && <4.10
42 build-depends: base >=4.7 && <4.10
42 , base-compat >=0.6.0 && <0.10
43 , base-compat >=0.6.0 && <0.10
43 , aeson
44 , aeson
44 , containers
45 , containers
45 , hashable
46 , hashable
47+ , generics-sop >=0.2 && <0.3
46 , http-media
48 , http-media
49+ , insert-ordered-containers >=0.1.0.0 && <0.2
47 , lens
50 , lens
48 , mtl
51 , mtl
49 , network
52 , network
@@ -60,13 +63,16 @@ test-suite spec
60 type: exitcode-stdio-1.0
63 type: exitcode-stdio-1.0
61 hs-source-dirs: test
64 hs-source-dirs: test
62 main-is: Spec.hs
65 main-is: Spec.hs
66+ -- We need aeson's toEncoding for doctests too
63 build-depends: base
67 build-depends: base
64 , base-compat
68 , base-compat
65− , aeson
69+ , aeson >=0.10.0.0
66 , aeson-qq
70 , aeson-qq
71+ , bytestring
67 , containers
72 , containers
68 , hashable
73 , hashable
69 , hspec
74 , hspec
75+ , insert-ordered-containers
70 , HUnit
76 , HUnit
71 , mtl
77 , mtl
72 , QuickCheck
78 , QuickCheck
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
test/Data/Swagger/SchemaSpec.hs+48−1
@@ -7,10 +7,12 @@ module Data.Swagger.SchemaSpec where
7import Prelude ()
7import Prelude ()
8import Prelude.Compat
8import Prelude.Compat
9
9
10+import Control.Lens ((^.))
10import Data.Aeson
11import Data.Aeson
11import Data.Aeson.QQ
12import Data.Aeson.QQ
12import Data.Char
13import Data.Char
13import qualified Data.HashMap.Strict as HashMap
14import qualified Data.HashMap.Strict as HashMap
15+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
14import Data.Proxy
16import Data.Proxy
15import Data.Set (Set)
17import Data.Set (Set)
16import qualified Data.Set as Set
18import qualified Data.Set as Set
@@ -34,10 +36,17 @@ checkSchemaName sname proxy =
34checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
36checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
35checkDefs proxy names =
37checkDefs proxy names =
36 it ("uses these definitions " ++ show names) $
38 it ("uses these definitions " ++ show names) $
37− Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
39+ InsOrdHashMap.keys defs `shouldBe` map Text.pack names
38 where
40 where
39 defs = execDeclare (declareNamedSchema proxy) mempty
41 defs = execDeclare (declareNamedSchema proxy) mempty
40
42
43+checkProperties :: ToSchema a => Proxy a -> [String] -> Spec
44+checkProperties proxy names =
45+ it ("has these fields in order " ++ show names) $
46+ InsOrdHashMap.keys fields `shouldBe` map Text.pack names
47+ where
48+ fields = toSchema proxy ^. properties
49+
41checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
50checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
42checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
43
52
@@ -58,6 +67,9 @@ spec = do
58 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
67 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
59 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
68 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
60 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
69 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
70+ context "Point5 (many field record)" $ do
71+ checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON
72+ checkProperties (Proxy :: Proxy Point5) point5Properties
61 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
73 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
62 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
74 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
63 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
75 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
@@ -143,6 +155,7 @@ ispairSchemaJSON = [aesonQQ|
143-- ========================================================================
155-- ========================================================================
144-- Point (record data type with custom fieldLabelModifier)
156-- Point (record data type with custom fieldLabelModifier)
145-- ========================================================================
157-- ========================================================================
158+
146data Point = Point
159data Point = Point
147 { pointX :: Double
160 { pointX :: Double
148 , pointY :: Double
161 , pointY :: Double
@@ -165,6 +178,40 @@ pointSchemaJSON = [aesonQQ|
165}
178}
166|]
179|]
167
180
181+-- ========================================================================
182+-- Point (record data type with multiple fields)
183+-- ========================================================================
184+
185+data Point5 = Point5
186+ { point5X :: Double
187+ , point5Y :: Double
188+ , point5Z :: Double
189+ , point5U :: Double
190+ , point5V :: Double -- 5 dimensional!
191+ } deriving (Generic)
192+
193+instance ToSchema Point5 where
194+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
195+ { fieldLabelModifier = map toLower . drop (length "point5") }
196+
197+point5SchemaJSON :: Value
198+point5SchemaJSON = [aesonQQ|
199+{
200+ "type": "object",
201+ "properties":
202+ {
203+ "x": { "type": "number", "format": "double" },
204+ "y": { "type": "number", "format": "double" },
205+ "z": { "type": "number", "format": "double" },
206+ "u": { "type": "number", "format": "double" },
207+ "v": { "type": "number", "format": "double" }
208+ },
209+ "required": ["x", "y", "z", "u", "v"]
210+}
211+|]
212+
213+point5Properties :: [String]
214+point5Properties = ["x", "y", "z", "u", "v"]
168
215
169-- ========================================================================
216-- ========================================================================
170-- Color (enum)
217-- Color (enum)
test/SpecCommon.hs+7−2
@@ -1,6 +1,7 @@
1module SpecCommon where
1module SpecCommon where
2
2
3import Data.Aeson
3import Data.Aeson
4+import Data.ByteString.Builder (toLazyByteString)
4import qualified Data.Foldable as F
5import qualified Data.Foldable as F
5import qualified Data.HashMap.Strict as HashMap
6import qualified Data.HashMap.Strict as HashMap
6import qualified Data.Vector as Vector
7import qualified Data.Vector as Vector
@@ -21,5 +22,9 @@ x <=> js = do
21 toJSON x `shouldBe` js
22 toJSON x `shouldBe` js
22 it "decodes correctly" $ do
23 it "decodes correctly" $ do
23 fromJSON js `shouldBe` Success x
24 fromJSON js `shouldBe` Success x
24−
25+ it "roundtrips: eitherDecode . encode" $ do
25−
26+ eitherDecode (encode x) `shouldBe` Right x
27+ it "roundtrips with toJSON" $ do
28+ eitherDecode (encode $ toJSON x) `shouldBe` Right x
29+ it "roundtrips with toEncoding" $ do
30+ eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x