e1ccb48 · typeable/openapi3

git.iko.soy/typeable/openapi3

Merge pull request #56 from phadej/ordhashmap

Add OrdHashMap

commite1ccb48aae7e1d39332d4fc640a4ecec658bfec2 authorNickolay Kudasov <fizruk@users.noreply.github.com> dateThu 17 Mar 2016, 17:38 (11 years ago) parent474a68b 1d25fb1

14 files changed+683−195

compare with master

unifiedsplit

src/Data/Swagger.hs+3−3 src/Data/Swagger/Internal.hs+227−106 src/Data/Swagger/Internal/AesonUtils.hs+333 src/Data/Swagger/Internal/Schema.hs+20−16 src/Data/Swagger/Internal/Schema/Validation.hs+4−2 src/Data/Swagger/Internal/Utils.hs+6−45 src/Data/Swagger/Lens.hs+8−7 src/Data/Swagger/Operation.hs+9−8 stack-lts-2.yaml+4−1 stack.yaml+4−2 swagger2.cabal+7−1 test/Data/Swagger/ParamSchemaSpec.hs+3−1 test/Data/Swagger/SchemaSpec.hs+48−1 test/SpecCommon.hs+7−2

src/Data/Swagger.hs+3−3

@@ -186,7 +186,7 @@ import Data.Swagger.Internal

186186-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))

187187-- & at 404 ?~ "User info not found")) ]

188188-- :}

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\"}}}"

190190--

191191-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@

192192-- which produces @application/json@ output. It should respond with code @200@ and body specified

@@ -205,7 +205,7 @@ import Data.Swagger.Internal

205205-- & type_ .~ SwaggerBoolean

206206-- & description ?~ "To be or not to be"

207207-- :}

208−-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"

208+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

209209--

210210-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).

211211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.

@@ -271,7 +271,7 @@ import Data.Swagger.Internal

271271-- >>> encode (Person "David" 28)

272272-- "{\"age\":28,\"name\":\"David\"}"

273273-- >>> 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\"}"

275275

276276-- $manipulation

277277-- Sometimes you have to work with an imported or generated @'Swagger'@.

src/Data/Swagger/Internal.hs+227−106

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE DeriveDataTypeable #-}

34{-# LANGUAGE DeriveFunctor #-}

45{-# LANGUAGE DeriveGeneric #-}

@@ -11,19 +12,23 @@

1112{-# LANGUAGE RecordWildCards #-}

1213{-# LANGUAGE ScopedTypeVariables #-}

1314{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TemplateHaskell #-}

16+{-# LANGUAGE TypeFamilies #-}

1417{-# LANGUAGE UndecidableInstances #-}

18+#if __GLASGOW_HASKELL__ <710

19+{-# LANGUAGE PolyKinds #-}

20+#endif

1521#include "overlapping-compat.h"

1622module Data.Swagger.Internal where

1723

1824import Prelude ()

1925import Prelude.Compat

2026

27+import Control.Lens ((&), (.~), (?~))

2128import Control.Applicative

22−import Control.Monad

2329import Data.Aeson

2430import qualified Data.Aeson.Types as JSON

2531import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)

26−import Data.HashMap.Strict (HashMap)

2732import qualified Data.HashMap.Strict as HashMap

2833import Data.Map (Map)

2934import qualified Data.Map as Map

@@ -38,10 +43,29 @@ import Network (HostName, PortNumber)

3843import Network.HTTP.Media (MediaType)

3944import Text.Read (readMaybe)

4045

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)

4158import Data.Swagger.Internal.Utils

4259

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+

4367-- | A list of definitions that can be used in references.

44−type Definitions = HashMap Text

68+type Definitions = InsOrdHashMap Text

4569

4670-- | This is the root document object for the API specification.

4771data Swagger = Swagger

@@ -73,7 +97,7 @@ data Swagger = Swagger

7397 -- | The available paths and operations for the API.

7498 -- Holds the relative paths to the individual endpoints.

7599 -- The path is appended to the @'basePath'@ in order to construct the full URL.

76− , _swaggerPaths :: HashMap FilePath PathItem

100+ , _swaggerPaths :: InsOrdHashMap FilePath PathItem

77101

78102 -- | An object to hold data types produced and consumed by operations.

79103 , _swaggerDefinitions :: Definitions Schema

@@ -330,8 +354,8 @@ data ParamOtherSchema = ParamOtherSchema

330354 -- Default value is @False@.

331355 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool

332356

333− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema

334− } deriving (Eq, Show, Generic, Data, Typeable)

357+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema

358+ } deriving (Eq, Show, Generic, Typeable, Data)

335359

336360-- | Items for @'SwaggerArray'@ schemas.

337361--

@@ -344,9 +368,9 @@ data ParamOtherSchema = ParamOtherSchema

344368--

345369-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.

346370data SwaggerItems t where

347− SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t

348− SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema

349− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema

371+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k

372+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema

373+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema

350374 deriving (Typeable)

351375

352376deriving instance Eq (SwaggerItems t)

@@ -356,17 +380,66 @@ deriving instance Show (SwaggerItems t)

356380swaggerItemsPrimitiveConstr :: Constr

357381swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix

358382

383+swaggerItemsObjectConstr :: Constr

384+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix

385+

386+swaggerItemsArrayConstr :: Constr

387+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix

388+

359389swaggerItemsDataType :: DataType

360390swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]

361391

362−instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where

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+

395+instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where

396+ -- TODO: define gfoldl

363397 gunfold k z c = case constrIndex c of

364398 1 -> k (k (z SwaggerItemsPrimitive))

365399 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."

366400 toConstr _ = swaggerItemsPrimitiveConstr

367401 dataTypeOf _ = swaggerItemsDataType

368402

369−deriving instance Data (SwaggerItems Schema)

403+-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only

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

370443

371444data SwaggerType t where

372445 SwaggerString :: SwaggerType t

@@ -374,9 +447,9 @@ data SwaggerType t where

374447 SwaggerInteger :: SwaggerType t

375448 SwaggerBoolean :: SwaggerType t

376449 SwaggerArray :: SwaggerType t

377− SwaggerFile :: SwaggerType ParamOtherSchema

378− SwaggerNull :: SwaggerType Schema

379− SwaggerObject :: SwaggerType Schema

450+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema

451+ SwaggerNull :: SwaggerType 'SwaggerKindSchema

452+ SwaggerObject :: SwaggerType 'SwaggerKindSchema

380453 deriving (Typeable)

381454

382455deriving instance Eq (SwaggerType t)

@@ -388,30 +461,30 @@ swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix

388461swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType

389462swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs

390463

391−swaggerCommonTypes :: [SwaggerType t]

464+swaggerCommonTypes :: [SwaggerType k]

392465swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]

393466

394−swaggerParamTypes :: [SwaggerType ParamOtherSchema]

467+swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]

395468swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

396469

397−swaggerSchemaTypes :: [SwaggerType Schema]

470+swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]

398471swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]

399472

400473swaggerTypeConstrs :: [Constr]

401−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])

474+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])

402475 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]

403476

404−instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where

477+instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where

405478 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

406479 toConstr = swaggerTypeConstr

407480 dataTypeOf = swaggerTypeDataType

408481

409−instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where

482+instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where

410483 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

411484 toConstr = swaggerTypeConstr

412485 dataTypeOf = swaggerTypeDataType

413486

414−instance OVERLAPPABLE_ Data (SwaggerType Schema) where

487+instance Data (SwaggerType 'SwaggerKindSchema) where

415488 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

416489 toConstr = swaggerTypeConstr

417490 dataTypeOf = swaggerTypeDataType

@@ -451,7 +524,7 @@ data CollectionFormat t where

451524 -- Corresponds to multiple parameter instances

452525 -- instead of multiple values for a single instance @foo=bar&foo=baz@.

453526 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.

454− CollectionMulti :: CollectionFormat ParamOtherSchema

527+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema

455528 deriving (Typeable)

456529

457530deriving instance Eq (CollectionFormat t)

@@ -467,12 +540,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $

467540collectionCommonFormats :: [CollectionFormat t]

468541collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]

469542

470−instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where

543+instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where

471544 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

472545 toConstr = collectionFormatConstr

473546 dataTypeOf _ = collectionFormatDataType

474547

475−deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)

548+deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)

476549

477550type ParamName = Text

478551

@@ -482,7 +555,7 @@ data Schema = Schema

482555 , _schemaRequired :: [ParamName]

483556

484557 , _schemaAllOf :: Maybe [Schema]

485− , _schemaProperties :: HashMap Text (Referenced Schema)

558+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

486559 , _schemaAdditionalProperties :: Maybe (Referenced Schema)

487560

488561 , _schemaDiscriminator :: Maybe Text

@@ -494,7 +567,7 @@ data Schema = Schema

494567 , _schemaMaxProperties :: Maybe Integer

495568 , _schemaMinProperties :: Maybe Integer

496569

497− , _schemaParamSchema :: ParamSchema Schema

570+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema

498571 } deriving (Eq, Show, Generic, Data, Typeable)

499572

500573-- | A @'Schema'@ with an optional name.

@@ -507,7 +580,7 @@ data NamedSchema = NamedSchema

507580-- | Regex pattern for @string@ type.

508581type Pattern = Text

509582

510−data ParamSchema t = ParamSchema

583+data ParamSchema (t :: SwaggerKind *) = ParamSchema

511584 { -- | Declares the value of the parameter that the server will use if none is provided,

512585 -- for example a @"count"@ to control the number of results per page might default to @100@

513586 -- if not supplied by the client in the request.

@@ -532,7 +605,7 @@ data ParamSchema t = ParamSchema

532605 , _paramSchemaMultipleOf :: Maybe Scientific

533606 } deriving (Eq, Show, Generic, Typeable)

534607

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)

536609

537610data Xml = Xml

538611 { -- | Replaces the name of the element/attribute used for the described schema property.

@@ -574,7 +647,7 @@ data Responses = Responses

574647

575648 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).

576649 -- Describes the expected response for those HTTP status codes.

577− , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)

650+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)

578651 } deriving (Eq, Show, Generic, Data, Typeable)

579652

580653type HttpStatusCode = Int

@@ -593,7 +666,7 @@ data Response = Response

593666 , _responseSchema :: Maybe (Referenced Schema)

594667

595668 -- | A list of headers that are sent with the response.

596− , _responseHeaders :: HashMap HeaderName Header

669+ , _responseHeaders :: InsOrdHashMap HeaderName Header

597670

598671 -- | An example of the response message.

599672 , _responseExamples :: Maybe Example

@@ -608,7 +681,7 @@ data Header = Header

608681 { -- | A short description of the header.

609682 _headerDescription :: Maybe Text

610683

611− , _headerParamSchema :: ParamSchema Header

684+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)

612685 } deriving (Eq, Show, Generic, Data, Typeable)

613686

614687data Example = Example { getExample :: Map MediaType Value }

@@ -659,7 +732,7 @@ data OAuth2Params = OAuth2Params

659732 _oauth2Flow :: OAuth2Flow

660733

661734 -- | The available scopes for the OAuth2 security scheme.

662− , _oauth2Scopes :: HashMap Text Text

735+ , _oauth2Scopes :: InsOrdHashMap Text Text

663736 } deriving (Eq, Show, Generic, Data, Typeable)

664737

665738data SecuritySchemeType

@@ -680,7 +753,7 @@ data SecurityScheme = SecurityScheme

680753-- The object can have multiple security schemes declared in it which are all required

681754-- (that is, there is a logical AND between the schemes).

682755newtype SecurityRequirement = SecurityRequirement

683− { getSecurityRequirement :: HashMap Text [Text]

756+ { getSecurityRequirement :: InsOrdHashMap Text [Text]

684757 } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)

685758

686759-- | Tag name.

@@ -814,9 +887,9 @@ instance SwaggerMonoid ParamLocation where

814887 swaggerMempty = ParamQuery

815888 swaggerMappend _ y = y

816889

817−instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where

818− swaggerMempty = HashMap.empty

819− swaggerMappend = HashMap.unionWith mappend

890+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where

891+ swaggerMempty = InsOrdHashMap.empty

892+ swaggerMappend = InsOrdHashMap.unionWith mappend

820893

821894instance Monoid a => SwaggerMonoid (Referenced a) where

822895 swaggerMempty = Inline mempty

@@ -914,7 +987,8 @@ instance ToJSON OAuth2Flow where

914987 , "tokenUrl" .= tokenUrl ]

915988

916989instance ToJSON OAuth2Params where

917− toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")

990+ toJSON = sopSwaggerGenericToJSON

991+ DEFINE_TOENCODING

918992

919993instance ToJSON SecuritySchemeType where

920994 toJSON SecuritySchemeBasic

@@ -927,24 +1001,22 @@ instance ToJSON SecuritySchemeType where

9271001 <+> object [ "type" .= ("oauth2" :: Text) ]

9281002

9291003instance ToJSON Swagger where

930− toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")

931− where

932− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)

933− addVersion _ = error "impossible"

1004+ toJSON = sopSwaggerGenericToJSON

1005+ DEFINE_TOENCODING

9341006

9351007instance ToJSON SecurityScheme where

936− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")

1008+ toJSON = sopSwaggerGenericToJSON

1009+ DEFINE_TOENCODING

9371010

9381011instance ToJSON Schema where

939− toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")

940− where

941− f "items" (Array _) = True

942− f _ _ = False

1012+ toJSON = sopSwaggerGenericToJSON

1013+ DEFINE_TOENCODING

9431014

9441015instance ToJSON Header where

945− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")

1016+ toJSON = sopSwaggerGenericToJSON

1017+ DEFINE_TOENCODING

9461018

947−instance ToJSON (SwaggerItems t) where

1019+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where

9481020 toJSON (SwaggerItemsPrimitive fmt schema) = object

9491021 [ "collectionFormat" .= fmt

9501022 , "items" .= schema ]

@@ -961,27 +1033,32 @@ instance ToJSON MimeList where

9611033 toJSON (MimeList xs) = toJSON (map show xs)

9621034

9631035instance ToJSON Param where

964− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")

1036+ toJSON = sopSwaggerGenericToJSON

1037+ DEFINE_TOENCODING

9651038

9661039instance ToJSON ParamAnySchema where

9671040 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]

9681041 toJSON (ParamOther s) = toJSON s

9691042

9701043instance ToJSON ParamOtherSchema where

971− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")

1044+ toJSON = sopSwaggerGenericToJSON

1045+ DEFINE_TOENCODING

9721046

9731047instance ToJSON Responses where

974− toJSON (Responses def rs) = omitEmpties $

975− toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]

1048+ toJSON = sopSwaggerGenericToJSON

1049+ DEFINE_TOENCODING

9761050

9771051instance ToJSON Response where

978− toJSON = omitEmpties . genericToJSON (jsonPrefix "response")

1052+ toJSON = sopSwaggerGenericToJSON

1053+ DEFINE_TOENCODING

9791054

9801055instance ToJSON Operation where

981− toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")

1056+ toJSON = sopSwaggerGenericToJSON

1057+ DEFINE_TOENCODING

9821058

9831059instance ToJSON PathItem where

984− toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")

1060+ toJSON = sopSwaggerGenericToJSON

1061+ DEFINE_TOENCODING

9851062

9861063instance ToJSON Example where

9871064 toJSON = toJSON . Map.mapKeys show . getExample

@@ -1014,11 +1091,10 @@ instance ToJSON (CollectionFormat t) where

10141091 toJSON CollectionPipes = "pipes"

10151092 toJSON CollectionMulti = "multi"

10161093

1017−instance ToJSON (ParamSchema t) where

1018− toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")

1019− where

1020− f "items" (Array _) = True

1021− f _ _ = False

1094+instance ToJSON (ParamSchema k) where

1095+ -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?

1096+ toJSON = sopSwaggerGenericToJSONWithOpts $

1097+ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

10221098

10231099-- =======================================================================

10241100-- Manual FromJSON instances

@@ -1038,7 +1114,7 @@ instance FromJSON OAuth2Flow where

10381114 parseJSON _ = empty

10391115

10401116instance FromJSON OAuth2Params where

1041− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")

1117+ parseJSON = sopSwaggerGenericParseJSON

10421118

10431119instance FromJSON SecuritySchemeType where

10441120 parseJSON js@(Object o) = do

@@ -1051,38 +1127,28 @@ instance FromJSON SecuritySchemeType where

10511127 parseJSON _ = empty

10521128

10531129instance FromJSON Swagger where

1054− parseJSON js@(Object o) = do

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

1130+ parseJSON = sopSwaggerGenericParseJSON

10681131

10691132instance FromJSON SecurityScheme where

1070− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")

1133+ parseJSON = sopSwaggerGenericParseJSON

10711134

10721135instance FromJSON Schema where

1073− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")

1074− `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)

1075− , "required" .= ([] :: [ParamName]) ]

1136+ parseJSON = sopSwaggerGenericParseJSON

10761137

10771138instance FromJSON Header where

1078− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")

1139+ parseJSON = sopSwaggerGenericParseJSON

10791140

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

10811142 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive

10821143 <$> o .:? "collectionFormat"

10831144 <*> (o .: "items" >>= parseJSON)

10841145

1085−instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where

1146+instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where

1147+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive

1148+ <$> o .:? "collectionFormat"

1149+ <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))

1150+

1151+instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

10861152 parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js

10871153 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js

10881154 parseJSON _ = empty

@@ -1100,7 +1166,7 @@ instance FromJSON MimeList where

11001166 parseJSON js = (MimeList . map fromString) <$> parseJSON js

11011167

11021168instance FromJSON Param where

1103− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")

1169+ parseJSON = sopSwaggerGenericParseJSON

11041170

11051171instance FromJSON ParamAnySchema where

11061172 parseJSON js@(Object o) = do

@@ -1113,12 +1179,12 @@ instance FromJSON ParamAnySchema where

11131179 parseJSON _ = empty

11141180

11151181instance FromJSON ParamOtherSchema where

1116− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")

1182+ parseJSON = sopSwaggerGenericParseJSON

11171183

11181184instance FromJSON Responses where

11191185 parseJSON (Object o) = Responses

11201186 <$> o .:? "default"

1121− <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)

1187+ <*> (parseJSON (Object (HashMap.delete "default" o)))

11221188 parseJSON _ = empty

11231189

11241190instance FromJSON Example where

@@ -1127,18 +1193,13 @@ instance FromJSON Example where

11271193 pure $ Example (Map.mapKeys fromString m)

11281194

11291195instance FromJSON Response where

1130− parseJSON = genericParseJSON (jsonPrefix "response")

1131− `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]

1196+ parseJSON = sopSwaggerGenericParseJSON

11321197

11331198instance FromJSON Operation where

1134− parseJSON = genericParseJSON (jsonPrefix "operation")

1135− `withDefaults` [ "security" .= ([] :: [SecurityRequirement])

1136− , "tags" .= ([] :: [Tag])

1137− , "parameters" .= ([] :: [Referenced Param]) ]

1199+ parseJSON = sopSwaggerGenericParseJSON

11381200

11391201instance FromJSON PathItem where

1140− parseJSON = genericParseJSON (jsonPrefix "pathItem")

1141− `withDefaults` [ "parameters" .= ([] :: [Param]) ]

1202+ parseJSON = sopSwaggerGenericParseJSON

11421203

11431204instance FromJSON Reference where

11441205 parseJSON (Object o) = Reference <$> o .: "$ref"

@@ -1164,26 +1225,86 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#

11641225instance FromJSON Xml where

11651226 parseJSON = genericParseJSON (jsonPrefix "xml")

11661227

1167−instance FromJSON (SwaggerType Schema) where

1228+instance FromJSON (SwaggerType 'SwaggerKindSchema) where

11681229 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]

11691230

1170−instance FromJSON (SwaggerType ParamOtherSchema) where

1231+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where

11711232 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]

11721233

1173−instance OVERLAPPABLE_ FromJSON (SwaggerType t) where

1234+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where

11741235 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]

11751236

1176−instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where

1237+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where

11771238 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]

11781239

1179−instance FromJSON (CollectionFormat ParamOtherSchema) where

1180− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]

1240+-- NOTE: There aren't collections of 'Schema'

1241+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where

1242+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]

11811243

1182−-- NOTE: The constraints @FromJSON (SwaggerType t)@ and

1183−-- @FromJSON (SwaggerItems t)@ are necessary here!

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")

1244+instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where

1245+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]

11891246

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 @@

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE DataKinds #-}

67{-# LANGUAGE OverloadedLists #-}

78{-# LANGUAGE OverloadedStrings #-}

89{-# LANGUAGE PackageImports #-}

@@ -25,6 +26,7 @@ import Control.Applicative

2526import Control.Monad

2627import Control.Monad.Writer

2728import Data.Aeson

29+import qualified Data.Aeson.Types as Aeson

2830import Data.Char

2931import Data.Data (Data)

3032import Data.Foldable (traverse_)

@@ -33,6 +35,8 @@ import Data.HashMap.Strict (HashMap)

3335import qualified Data.HashMap.Strict as HashMap

3436import "unordered-containers" Data.HashSet (HashSet)

3537import qualified "unordered-containers" Data.HashSet as HashSet

38+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

39+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

3640import Data.Int

3741import Data.IntSet (IntSet)

3842import Data.IntMap (IntMap)

@@ -194,7 +198,7 @@ declareSchemaRef proxy = do

194198 -- have already declared it.

195199 -- If we have, we don't need to declare anything for

196200 -- this schema this time and thus simply return the reference.

197− known <- looks (HashMap.member name)

201+ known <- looks (InsOrdHashMap.member name)

198202 when (not known) $ do

199203 declare [(name, schema)]

200204 void $ declareNamedSchema proxy

@@ -213,7 +217,7 @@ inlineSchemasWhen p defs = template %~ deref

213217 where

214218 deref r@(Ref (Reference name))

215219 | p name =

216− case HashMap.lookup name defs of

220+ case InsOrdHashMap.lookup name defs of

217221 Just schema -> Inline (inlineSchemasWhen p defs schema)

218222 Nothing -> r

219223 | otherwise = r

@@ -255,7 +259,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s

255259inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

256260 where

257261 nonRecursive name =

258− case HashMap.lookup name defs of

262+ case InsOrdHashMap.lookup name defs of

259263 Just schema -> name `notElem` execDeclare (usedNames schema) mempty

260264 Nothing -> False

261265

@@ -267,7 +271,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

267271 seen <- looks (name `elem`)

268272 when (not seen) $ do

269273 declare [name]

270− traverse_ usedNames (HashMap.lookup name defs)

274+ traverse_ usedNames (InsOrdHashMap.lookup name defs)

271275 Inline subschema -> usedNames subschema

272276

273277-- | Default schema for binary data (any sequence of octets).

@@ -304,7 +308,7 @@ passwordSchema = mempty

304308-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

305309-- >>> instance ToJSON Person

306310-- >>> 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\"}"

308312sketchSchema :: ToJSON a => a -> Schema

309313sketchSchema = sketch . toJSON

310314 where

@@ -331,7 +335,7 @@ sketchSchema = sketch . toJSON

331335 go js@(Object o) = mempty

332336 & type_ .~ SwaggerObject

333337 & required .~ HashMap.keys o

334− & properties .~ fmap (Inline . go) o

338+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

335339

336340-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

337341-- Produced schema uses as much constraints as possible.

@@ -348,7 +352,7 @@ sketchSchema = sketch . toJSON

348352-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

349353-- >>> instance ToJSON Person

350354-- >>> 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\"}]}"

352356sketchStrictSchema :: ToJSON a => a -> Schema

353357sketchStrictSchema = go . toJSON

354358 where

@@ -381,7 +385,7 @@ sketchStrictSchema = go . toJSON

381385 go js@(Object o) = mempty

382386 & type_ .~ SwaggerObject

383387 & required .~ names

384− & properties .~ fmap (Inline . go) o

388+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

385389 & maxProperties ?~ fromIntegral (length names)

386390 & minProperties ?~ fromIntegral (length names)

387391 & enum_ ?~ [js]

@@ -564,8 +568,8 @@ gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts prox

564568

565569instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where

566570 gdeclareNamedSchema opts _ schema = do

567− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema

568− gdeclareNamedSchema opts (Proxy :: Proxy f) gschema

571+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema

572+ gdeclareNamedSchema opts (Proxy :: Proxy g) gschema

569573

570574instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where

571575 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s

@@ -605,16 +609,16 @@ gdeclareSchemaRef opts proxy = do

605609 -- have already declared it.

606610 -- If we have, we don't need to declare anything for

607611 -- this schema this time and thus simply return the reference.

608− known <- looks (HashMap.member name)

612+ known <- looks (InsOrdHashMap.member name)

609613 when (not known) $ do

610614 declare [(name, schema)]

611615 void $ gdeclareNamedSchema opts proxy mempty

612616 return $ Ref (Reference name)

613617 _ -> Inline <$> gdeclareSchema opts proxy

614618

615−appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)

619+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)

616620appendItem 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]))

618622appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

619623

620624withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>

@@ -630,7 +634,7 @@ withFieldSchema opts _ isRequiredField schema = do

630634 & type_ .~ SwaggerObject

631635 & properties . at fname ?~ ref

632636 & if isRequiredField

633− then required %~ (fname :)

637+ then required %~ (++ [fname])

634638 else id

635639 where

636640 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))

@@ -662,7 +666,7 @@ gdeclareNamedSumSchema opts proxy s

662666

663667 toStringTag schema = mempty

664668 & type_ .~ SwaggerString

665− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

669+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

666670

667671type AllNullary = All

668672

@@ -670,7 +674,7 @@ class GSumToSchema f where

670674 gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

671675

672676instance (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)

674678

675679gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

676680 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_)

3030import Data.HashMap.Strict (HashMap)

3131import qualified Data.HashMap.Strict as HashMap

3232import qualified "unordered-containers" Data.HashSet as HashSet

33+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

34+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

3335import Data.Monoid

3436import Data.Proxy

3537import Data.Scientific (Scientific, isInteger)

@@ -174,7 +176,7 @@ sub_ = lmap . view

174176-- | Validate value against a schema given schema reference and validation function.

175177withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

176178withRef (Reference ref) f = withConfig $ \cfg ->

177− case HashMap.lookup ref (configDefinitions cfg) of

179+ case InsOrdHashMap.lookup ref (configDefinitions cfg) of

178180 Nothing -> invalid $ "unknown schema " ++ show ref

179181 Just s -> f s

180182

@@ -290,7 +292,7 @@ validateObject o = withSchema $ \schema ->

290292 case v of

291293 Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property

292294 _ ->

293− case HashMap.lookup k (schema ^. properties) of

295+ case InsOrdHashMap.lookup k (schema ^. properties) of

294296 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

295297 Just s -> validateWithSchemaRef s v

296298

src/Data/Swagger/Internal/Utils.hs+6−45

@@ -9,8 +9,6 @@ module Data.Swagger.Internal.Utils where

99import Prelude ()

1010import Prelude.Compat

1111

12−import Control.Arrow (first)

13−import Control.Applicative

1412import Control.Lens ((&), (%~))

1513import Control.Lens.TH

1614import Data.Aeson

@@ -20,13 +18,14 @@ import Data.Data

2018import Data.Hashable (Hashable)

2119import Data.HashMap.Strict (HashMap)

2220import qualified Data.HashMap.Strict as HashMap

21+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

22+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

2323import Data.Map (Map)

2424import Data.Monoid

2525import Data.Set (Set)

2626import Data.Text (Text)

2727import GHC.Generics

2828import Language.Haskell.TH (mkName)

29−import Text.Read (readMaybe)

3029

3130swaggerFieldRules :: LensRules

3231swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer

@@ -53,17 +52,6 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of

5352 Just x -> z x

5453 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."

5554

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−

6755jsonPrefix :: String -> Options

6856jsonPrefix prefix = defaultOptions

6957 { fieldLabelModifier = modifier . drop 1

@@ -85,40 +73,10 @@ parseOneOf xs js =

8573 where

8674 ys = zip (map toJSON xs) xs

8775

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−

11476(<+>) :: Value -> Value -> Value

11577Object x <+> Object y = Object (x <> y)

11678_ <+> _ = error "<+>: merging non-objects"

11779

118−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a

119−withDefaults parser defs js@(Object _) = parser (js <+> object defs)

120−withDefaults _ _ _ = empty

121−

12280genericMempty :: (Generic a, GMonoid (Rep a)) => a

12381genericMempty = to gmempty

12482

@@ -161,6 +119,10 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where

161119 swaggerMempty = mempty

162120 swaggerMappend = HashMap.unionWith (\_old new -> new)

163121

122+instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where

123+ swaggerMempty = mempty

124+ swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)

125+

164126instance SwaggerMonoid Text where

165127 swaggerMempty = mempty

166128 swaggerMappend x "" = x

@@ -170,4 +132,3 @@ instance SwaggerMonoid (Maybe a) where

170132 swaggerMempty = Nothing

171133 swaggerMappend x Nothing = x

172134 swaggerMappend _ y = y

173−

src/Data/Swagger/Lens.hs+8−7

@@ -7,6 +7,7 @@

77{-# LANGUAGE RankNTypes #-}

88{-# LANGUAGE TemplateHaskell #-}

99{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE DataKinds #-}

1011{-# LANGUAGE UndecidableInstances #-}

1112{-# OPTIONS_GHC -fno-warn-orphans #-}

1213#include "overlapping-compat.h"

@@ -59,14 +60,14 @@ makePrisms ''Referenced

5960

6061-- ** 'SwaggerItems' prisms

6162

62−_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]

63+_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

6364_SwaggerItemsArray

6465 = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

6566 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

6667 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

6768 SwaggerItemsArray a -> Right a

6869

69−_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)

70+_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

7071_SwaggerItemsObject

7172 = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

7273 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

@@ -91,13 +92,13 @@ instance At Responses where at n = responses . at n

9192instance Ixed Operation where ix n = responses . ix n

9293instance At Operation where at n = responses . at n

9394

94−instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema

95+instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

9596

9697-- HasType instances

97−instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_

98−instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_

99−instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_

100−instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_

98+instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_

99+instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

100+instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

101+instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

101102

102103-- HasDefault instances

103104instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+9−8

@@ -46,6 +46,9 @@ import Data.Swagger.Internal

4646import Data.Swagger.Lens

4747import Data.Swagger.Schema

4848

49+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

50+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

51+

4952-- $setup

5053-- >>> import Data.Aeson

5154-- >>> import Data.Proxy

@@ -58,10 +61,8 @@ import Data.Swagger.Schema

5861-- >>> encode $ prependPath "user/{user_id}" api ^. paths

5962-- "{\"/user/{user_id}/info\":{}}"

6063prependPath :: FilePath -> Swagger -> Swagger

61−prependPath path = paths %~ mapKeys (path </>)

64+prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)

6265 where

63− mapKeys f = HashMap.fromList . map (first f) . HashMap.toList

64−

6566 x </> y = case trim y of

6667 "" -> "/" <> trim x

6768 y' -> "/" <> trim x <> "/" <> y'

@@ -80,15 +81,15 @@ allOperations = paths.traverse.template

8081-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]

8182-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

8283-- >>> 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\"}}}}}}"

8485-- >>> 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\"}}}}}}"

8687operationsOf :: Swagger -> Traversal' Swagger Operation

8788operationsOf sub = paths.itraversed.withIndex.subops

8889 where

8990 -- | Traverse operations that correspond to paths and methods of the sub API.

9091 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

9293 Just subitem -> (,) path <$> methodsOf subitem f item

9394 Nothing -> pure (path, item)

9495

@@ -119,7 +120,7 @@ applyTagsFor ops ts swag = swag

119120-- necessary schema definitions.

120121--

121122-- >>> 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\"}}]"

123124declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

124125declareResponse proxy = do

125126 s <- declareSchemaRef proxy

@@ -139,7 +140,7 @@ declareResponse proxy = do

139140-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

140141-- >>> let res = declareResponse (Proxy :: Proxy Day)

141142-- >>> 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\"}}}"

143144--

144145-- See also @'setResponseWith'@.

145146setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

stack-lts-2.yaml+4−1

@@ -1,5 +1,8 @@

11flags: {}

22packages:

33- '.'

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

58resolver: lts-2.22

stack.yaml+4−2

@@ -1,5 +1,7 @@

11flags: {}

22packages:

33- '.'

4−extra-deps: []

5−resolver: nightly-2016-01-26

4+extra-deps:

5+- aeson-0.11.1.0

6+- insert-ordered-containers-0.1.0.1

7+resolver: nightly-2016-03-04

swagger2.cabal+7−1

@@ -38,12 +38,15 @@ library

3838 Data.Swagger.Internal.Schema.Validation

3939 Data.Swagger.Internal.ParamSchema

4040 Data.Swagger.Internal.Utils

41+ Data.Swagger.Internal.AesonUtils

4142 build-depends: base >=4.7 && <4.10

4243 , base-compat >=0.6.0 && <0.10

4344 , aeson

4445 , containers

4546 , hashable

47+ , generics-sop >=0.2 && <0.3

4648 , http-media

49+ , insert-ordered-containers >=0.1.0.0 && <0.2

4750 , lens

4851 , mtl

4952 , network

@@ -60,13 +63,16 @@ test-suite spec

6063 type: exitcode-stdio-1.0

6164 hs-source-dirs: test

6265 main-is: Spec.hs

66+ -- We need aeson's toEncoding for doctests too

6367 build-depends: base

6468 , base-compat

65− , aeson

69+ , aeson >=0.10.0.0

6670 , aeson-qq

71+ , bytestring

6772 , containers

6873 , hashable

6974 , hspec

75+ , insert-ordered-containers

7076 , HUnit

7177 , mtl

7278 , QuickCheck

test/Data/Swagger/ParamSchemaSpec.hs+3−1

@@ -1,4 +1,5 @@

11{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE TemplateHaskell #-}

45{-# LANGUAGE QuasiQuotes #-}

@@ -11,12 +12,13 @@ import Data.Proxy

1112import GHC.Generics

1213

1314import Data.Swagger

15+import Data.Swagger.Internal (SwaggerKind(..))

1416

1517import SpecCommon

1618import Test.Hspec

1719

1820checkToParamSchema :: 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

2022

2123spec :: Spec

2224spec = do

test/Data/Swagger/SchemaSpec.hs+48−1

@@ -7,10 +7,12 @@ module Data.Swagger.SchemaSpec where

77import Prelude ()

88import Prelude.Compat

10+import Control.Lens ((^.))

1011import Data.Aeson

1112import Data.Aeson.QQ

1213import Data.Char

1314import qualified Data.HashMap.Strict as HashMap

15+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

1416import Data.Proxy

1517import Data.Set (Set)

1618import qualified Data.Set as Set

@@ -34,10 +36,17 @@ checkSchemaName sname proxy =

3436checkDefs :: ToSchema a => Proxy a -> [String] -> Spec

3537checkDefs proxy names =

3638 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

3840 where

3941 defs = execDeclare (declareNamedSchema proxy) mempty

4042

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+

4150checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec

4251checkInlinedSchema proxy js = toInlinedSchema proxy <=> js

4352

@@ -58,6 +67,9 @@ spec = do

5867 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON

5968 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON

6069 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

6173 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON

6274 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON

6375 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON

@@ -143,6 +155,7 @@ ispairSchemaJSON = [aesonQQ|

143155-- ========================================================================

144156-- Point (record data type with custom fieldLabelModifier)

145157-- ========================================================================

158+

146159data Point = Point

147160 { pointX :: Double

148161 , pointY :: Double

@@ -165,6 +178,40 @@ pointSchemaJSON = [aesonQQ|

165178}

166179|]

167180

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"]

168215

169216-- ========================================================================

170217-- Color (enum)

test/SpecCommon.hs+7−2

@@ -1,6 +1,7 @@

11module SpecCommon where

33import Data.Aeson

4+import Data.ByteString.Builder (toLazyByteString)

45import qualified Data.Foldable as F

56import qualified Data.HashMap.Strict as HashMap

67import qualified Data.Vector as Vector

@@ -21,5 +22,9 @@ x <=> js = do

2122 toJSON x `shouldBe` js

2223 it "decodes correctly" $ do

2324 fromJSON js `shouldBe` Success x

24−

25−

25+ it "roundtrips: eitherDecode . encode" $ do

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