0eb35c7 · typeable/swagger2

git.iko.soy/typeable/swagger2

Merge pull request #23 from GetShopTV/remove-useReferences-#21

Remove useReferences from SchemaOptions

commit0eb35c7cb97e1fdd4be7d79fc97ea7a8e44a29b2 authorNickolay Kudasov <fizruk@users.noreply.github.com> dateSat 19 Dec 2015, 00:18 (11 years ago) parentd776474 dd64c84

7 files changed+380−56

compare with master

unifiedsplit

.travis.yml+1−1 src/Data/Swagger/Internal.hs+131−35 src/Data/Swagger/Internal/Schema.hs+97−2 src/Data/Swagger/Internal/Utils.hs+7 src/Data/Swagger/Schema.hs+7 src/Data/Swagger/SchemaOptions.hs−18 test/Data/Swagger/SchemaSpec.hs+137

.travis.yml+1−1

@@ -29,7 +29,7 @@ install:

2929script:

3030 - if [ -f configure.ac ]; then autoreconf -i; fi

3131 - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging

32− - cabal build # this builds all libraries and executables (including tests/benchmarks)

32+ - cabal build --ghc-options="-O0" # this builds all libraries and executables (including tests/benchmarks)

3333 - cabal test

3434 - cabal check

3535 - cabal sdist # tests that a source-distribution can be generated

src/Data/Swagger/Internal.hs+131−35

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

12{-# LANGUAGE DeriveGeneric #-}

23{-# LANGUAGE DeriveTraversable #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -16,6 +17,7 @@ import Control.Monad

1617import Data.Aeson

1718import Data.Aeson.TH (deriveJSON)

1819import qualified Data.Aeson.Types as JSON

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

1921import Data.HashMap.Strict (HashMap)

2022import qualified Data.HashMap.Strict as HashMap

2123import Data.Map (Map)

@@ -91,7 +93,7 @@ data Swagger = Swagger

9193

9294 -- | Additional external documentation.

9395 , _externalDocs :: Maybe ExternalDocs

94− } deriving (Eq, Show, Generic)

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

9597

9698-- | The object provides metadata about the API.

9799-- The metadata can be used by the clients if needed,

@@ -116,7 +118,7 @@ data Info = Info

116118 -- | Provides the version of the application API

117119 -- (not to be confused with the specification version).

118120 , _infoVersion :: Text

119− } deriving (Eq, Show, Generic)

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

120122

121123-- | Contact information for the exposed API.

122124data Contact = Contact

@@ -128,7 +130,7 @@ data Contact = Contact

128130

129131 -- | The email address of the contact person/organization.

130132 , _contactEmail :: Maybe Text

131− } deriving (Eq, Show)

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

132134

133135-- | License information for the exposed API.

134136data License = License

@@ -137,13 +139,26 @@ data License = License

137139

138140 -- | A URL to the license used for the API.

139141 , _licenseUrl :: Maybe URL

140− } deriving (Eq, Show)

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

141143

142144-- | The host (name or ip) serving the API. It MAY include a port.

143145data Host = Host

144146 { _hostName :: HostName -- ^ Host name.

145147 , _hostPort :: Maybe PortNumber -- ^ Optional port.

146− } deriving (Eq, Show)

148+ } deriving (Eq, Show, Generic, Typeable)

149+

150+hostConstr :: Constr

151+hostConstr = mkConstr hostDataType "Host" [] Prefix

152+

153+hostDataType :: DataType

154+hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]

155+

156+instance Data Host where

157+ gunfold k z c = case constrIndex c of

158+ 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))

159+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."

160+ toConstr (Host _ _) = hostConstr

161+ dataTypeOf _ = hostDataType

147162

148163-- | The transfer protocol of the API.

149164data Scheme

@@ -151,14 +166,14 @@ data Scheme

151166 | Https

152167 | Ws

153168 | Wss

154− deriving (Eq, Show)

169+ deriving (Eq, Show, Generic, Data, Typeable)

155170

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

157172data Paths = Paths

158173 { -- | Holds the relative paths to the individual endpoints.

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

160175 _pathsMap :: HashMap FilePath PathItem

161− } deriving (Eq, Show, Generic)

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

162177

163178-- | Describes the operations available on a single path.

164179-- A @'PathItem'@ may be empty, due to ACL constraints.

@@ -191,7 +206,7 @@ data PathItem = PathItem

191206 -- The list MUST NOT include duplicated parameters.

192207 -- A unique parameter is defined by a combination of a name and location.

193208 , _pathItemParameters :: [Referenced Param]

194− } deriving (Eq, Show, Generic)

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

195210

196211-- | Describes a single API operation on a path.

197212data Operation = Operation

@@ -251,10 +266,23 @@ data Operation = Operation

251266 -- This definition overrides any declared top-level security.

252267 -- To remove a top-level security declaration, @Just []@ can be used.

253268 , _operationSecurity :: [SecurityRequirement]

254− } deriving (Eq, Show, Generic)

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

255270

256271newtype MimeList = MimeList { getMimeList :: [MediaType] }

257− deriving (Eq, Show, Monoid)

272+ deriving (Eq, Show, Monoid, Typeable)

273+

274+mimeListConstr :: Constr

275+mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix

276+

277+mimeListDataType :: DataType

278+mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]

279+

280+instance Data MimeList where

281+ gunfold k z c = case constrIndex c of

282+ 1 -> k (z (\xs -> MimeList (map fromString xs)))

283+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."

284+ toConstr (MimeList _) = mimeListConstr

285+ dataTypeOf _ = mimeListDataType

258286

259287-- | Describes a single operation parameter.

260288-- A unique parameter is defined by a combination of a name and location.

@@ -275,12 +303,12 @@ data Param = Param

275303

276304 -- | Parameter schema.

277305 , _paramSchema :: ParamAnySchema

278− } deriving (Eq, Show, Generic)

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

279307

280308data ParamAnySchema

281309 = ParamBody (Referenced Schema)

282310 | ParamOther ParamOtherSchema

283− deriving (Eq, Show)

311+ deriving (Eq, Show, Generic, Data, Typeable)

284312

285313data ParamOtherSchema = ParamOtherSchema

286314 { -- | The location of the parameter.

@@ -297,7 +325,7 @@ data ParamOtherSchema = ParamOtherSchema

297325 , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)

298326

299327 , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items

300− } deriving (Eq, Show, Generic)

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

301329

302330data SwaggerType t where

303331 SwaggerString :: SwaggerType t

@@ -311,6 +339,41 @@ data SwaggerType t where

311339

312340deriving instance Eq (SwaggerType t)

313341deriving instance Show (SwaggerType t)

342+deriving instance Typeable (SwaggerType t)

343+

344+swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr

345+swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix

346+

347+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType

348+swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs

349+

350+swaggerCommonTypes :: [SwaggerType t]

351+swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]

352+

353+swaggerParamTypes :: [SwaggerType ParamOtherSchema]

354+swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

355+

356+swaggerSchemaTypes :: [SwaggerType Schema]

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

358+

359+swaggerTypeConstrs :: [Constr]

360+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])

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

362+

363+instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerType t) where

364+ gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

365+ toConstr = swaggerTypeConstr

366+ dataTypeOf = swaggerTypeDataType

367+

368+instance {-# OVERLAPPING #-} Data (SwaggerType ParamOtherSchema) where

369+ gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

370+ toConstr = swaggerTypeConstr

371+ dataTypeOf = swaggerTypeDataType

372+

373+instance {-# OVERLAPPING #-} Data (SwaggerType Schema) where

374+ gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

375+ toConstr = swaggerTypeConstr

376+ dataTypeOf = swaggerTypeDataType

314377

315378data ParamLocation

316379 = -- | Parameters that are appended to the URL.

@@ -330,7 +393,7 @@ data ParamLocation

330393 -- Form parameters have a different format based on the content-type used

331394 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).

332395 | ParamFormData

333− deriving (Eq, Show)

396+ deriving (Eq, Show, Generic, Data, Typeable)

334397

335398type Format = Text

336399

@@ -351,6 +414,24 @@ data CollectionFormat t where

351414

352415deriving instance Eq (CollectionFormat t)

353416deriving instance Show (CollectionFormat t)

417+deriving instance Typeable (CollectionFormat t)

418+

419+collectionFormatConstr :: CollectionFormat t -> Constr

420+collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix

421+

422+collectionFormatDataType :: DataType

423+collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $

424+ map collectionFormatConstr collectionCommonFormats

425+

426+collectionCommonFormats :: [CollectionFormat t]

427+collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]

428+

429+instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where

430+ gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

431+ toConstr = collectionFormatConstr

432+ dataTypeOf _ = collectionFormatDataType

433+

434+deriving instance {-# OVERLAPPING #-} Data (CollectionFormat Param)

354435

355436type ParamName = Text

356437

@@ -373,12 +454,12 @@ data Schema = Schema

373454 , _schemaMinProperties :: Maybe Integer

374455

375456 , _schemaParamSchema :: ParamSchema Schema SchemaItems

376− } deriving (Eq, Show, Generic)

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

377458

378459data SchemaItems

379460 = SchemaItemsObject (Referenced Schema)

380461 | SchemaItemsArray [Referenced Schema]

381− deriving (Eq, Show)

462+ deriving (Eq, Show, Generic, Data, Typeable)

382463

383464data ParamSchema t items = ParamSchema

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

@@ -403,7 +484,9 @@ data ParamSchema t items = ParamSchema

403484 , _paramSchemaUniqueItems :: Maybe Bool

404485 , _paramSchemaEnum :: Maybe [Value]

405486 , _paramSchemaMultipleOf :: Maybe Scientific

406− } deriving (Eq, Show, Generic)

487+ } deriving (Eq, Show, Generic, Typeable)

488+

489+deriving instance (Data t, Data (SwaggerType t), Data i) => Data (ParamSchema t i)

407490

408491data Xml = Xml

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

@@ -431,7 +514,7 @@ data Xml = Xml

431514 -- Default value is @False@.

432515 -- The definition takes effect only when defined alongside type being array (outside the items).

433516 , _xmlWrapped :: Maybe Bool

434− } deriving (Eq, Show, Generic)

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

435518

436519data Items = Items

437520 { -- | Determines the format of the array if type array is used.

@@ -439,7 +522,7 @@ data Items = Items

439522 _itemsCollectionFormat :: Maybe (CollectionFormat Items)

440523

441524 , _itemsParamSchema :: ParamSchema Items Items

442− } deriving (Eq, Show, Generic)

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

443526

444527-- | A container for the expected responses of an operation.

445528-- The container maps a HTTP response code to the expected response.

@@ -454,7 +537,7 @@ data Responses = Responses

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

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

456539 , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)

457− } deriving (Eq, Show, Generic)

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

458541

459542type HttpStatusCode = Int

460543

@@ -476,7 +559,7 @@ data Response = Response

476559

477560 -- | An example of the response message.

478561 , _responseExamples :: Maybe Example

479− } deriving (Eq, Show, Generic)

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

480563

481564type HeaderName = Text

482565

@@ -489,16 +572,29 @@ data Header = Header

489572 , _headerCollectionFormat :: Maybe (CollectionFormat Items)

490573

491574 , _headerParamSchema :: ParamSchema Header Items

492− } deriving (Eq, Show, Generic)

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

493576

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

495− deriving (Eq, Show)

578+ deriving (Eq, Show, Generic, Typeable)

579+

580+exampleConstr :: Constr

581+exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix

582+

583+exampleDataType :: DataType

584+exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]

585+

586+instance Data Example where

587+ gunfold k z c = case constrIndex c of

588+ 1 -> k (z (\m -> Example (Map.mapKeys fromString m)))

589+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example."

590+ toConstr (Example _) = exampleConstr

591+ dataTypeOf _ = exampleDataType

496592

497593-- | The location of the API key.

498594data ApiKeyLocation

499595 = ApiKeyQuery

500596 | ApiKeyHeader

501− deriving (Eq, Show)

597+ deriving (Eq, Show, Generic, Data, Typeable)

502598

503599data ApiKeyParams = ApiKeyParams

504600 { -- | The name of the header or query parameter to be used.

@@ -506,7 +602,7 @@ data ApiKeyParams = ApiKeyParams

506602

507603 -- | The location of the API key.

508604 , _apiKeyIn :: ApiKeyLocation

509− } deriving (Eq, Show)

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

510606

511607-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.

512608type AuthorizationURL = Text

@@ -519,7 +615,7 @@ data OAuth2Flow

519615 | OAuth2Password TokenURL

520616 | OAuth2Application TokenURL

521617 | OAuth2AccessCode AuthorizationURL TokenURL

522− deriving (Eq, Show)

618+ deriving (Eq, Show, Generic, Data, Typeable)

523619

524620data OAuth2Params = OAuth2Params

525621 { -- | The flow used by the OAuth2 security scheme.

@@ -527,13 +623,13 @@ data OAuth2Params = OAuth2Params

527623

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

529625 , _oauth2Scopes :: HashMap Text Text

530− } deriving (Eq, Show, Generic)

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

531627

532628data SecuritySchemeType

533629 = SecuritySchemeBasic

534630 | SecuritySchemeApiKey ApiKeyParams

535631 | SecuritySchemeOAuth2 OAuth2Params

536− deriving (Eq, Show)

632+ deriving (Eq, Show, Generic, Data, Typeable)

537633

538634data SecurityScheme = SecurityScheme

539635 { -- | The type of the security scheme.

@@ -541,14 +637,14 @@ data SecurityScheme = SecurityScheme

541637

542638 -- | A short description for security scheme.

543639 , _securitySchemeDescription :: Maybe Text

544− } deriving (Eq, Show, Generic)

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

545641

546642-- | Lists the required security schemes to execute this operation.

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

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

549645newtype SecurityRequirement = SecurityRequirement

550646 { getSecurityRequirement :: HashMap Text [Text]

551− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON)

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

552648

553649-- | Allows adding meta data to a single tag that is used by @Operation@.

554650-- It is not mandatory to have a @Tag@ per tag used there.

@@ -562,7 +658,7 @@ data Tag = Tag

562658

563659 -- | Additional external documentation for this tag.

564660 , _tagExternalDocs :: Maybe ExternalDocs

565− } deriving (Eq, Show)

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

566662

567663-- | Allows referencing an external resource for extended documentation.

568664data ExternalDocs = ExternalDocs

@@ -572,19 +668,19 @@ data ExternalDocs = ExternalDocs

572668

573669 -- | The URL for the target documentation.

574670 , _externalDocsUrl :: URL

575− } deriving (Eq, Show, Generic)

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

576672

577673-- | A simple object to allow referencing other definitions in the specification.

578674-- It can be used to reference parameters and responses that are defined at the top level for reuse.

579675newtype Reference = Reference { getReference :: Text }

580− deriving (Eq, Show)

676+ deriving (Eq, Show, Data, Typeable)

581677

582678data Referenced a

583679 = Ref Reference

584680 | Inline a

585− deriving (Eq, Show)

681+ deriving (Eq, Show, Data, Typeable)

586682

587−newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)

683+newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)

588684

589685-- =======================================================================

590686-- Monoid instances

src/Data/Swagger/Internal/Schema.hs+97−2

@@ -14,10 +14,14 @@

1414module Data.Swagger.Internal.Schema where

1515

1616import Control.Lens

17+import Data.Data.Lens (template)

18+

1719import Control.Monad

1820import Control.Monad.Writer

1921import Data.Aeson

2022import Data.Char

23+import Data.Data (Data)

24+import Data.Foldable (traverse_)

2125import Data.HashMap.Strict (HashMap)

2226import qualified Data.HashMap.Strict as HashMap

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

@@ -119,19 +123,43 @@ declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema

119123declareSchema = fmap snd . declareNamedSchema

120124

121125-- | Convert a type into an optionally named schema.

126+--

127+-- >>> encode <$> toNamedSchema (Proxy :: Proxy String)

128+-- (Nothing,"{\"type\":\"string\"}")

129+--

130+-- >>> encode <$> toNamedSchema (Proxy :: Proxy Day)

131+-- (Just "Day","{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"}")

122132toNamedSchema :: ToSchema a => proxy a -> NamedSchema

123133toNamedSchema = undeclare . declareNamedSchema

124134

125135-- | Get type's schema name according to its @'ToSchema'@ instance.

136+--

137+-- >>> schemaName (Proxy :: Proxy Int)

138+-- Nothing

139+--

140+-- >>> schemaName (Proxy :: Proxy UTCTime)

141+-- Just "UTCTime"

126142schemaName :: ToSchema a => proxy a -> Maybe T.Text

127143schemaName = fst . toNamedSchema

128144

129145-- | Convert a type into a schema.

146+--

147+-- >>> encode $ toSchema (Proxy :: Proxy Int8)

148+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"

149+--

150+-- >>> encode $ toSchema (Proxy :: Proxy [Day])

151+-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"

130152toSchema :: ToSchema a => proxy a -> Schema

131153toSchema = snd . toNamedSchema

132154

133155-- | Convert a type into a referenced schema if possible.

134156-- Only named schemas can be referenced, nameless schemas are inlined.

157+--

158+-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)

159+-- "{\"type\":\"integer\"}"

160+--

161+-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)

162+-- "{\"$ref\":\"#/definitions/Day\"}"

135163toSchemaRef :: ToSchema a => proxy a -> Referenced Schema

136164toSchemaRef = undeclare . declareSchemaRef

137165

@@ -161,6 +189,75 @@ declareSchemaRef proxy = do

161189 return $ Ref (Reference name)

162190 _ -> Inline <$> declareSchema proxy

163191

192+-- | Inline any referenced schema if its name satisfies given predicate.

193+--

194+-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored

195+-- and schema stays referenced.

196+--

197+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas

198+-- when inlining recursive schemas.

199+inlineSchemasWhen :: Data s => (T.Text -> Bool) -> Definitions -> s -> s

200+inlineSchemasWhen p defs = template %~ deref

201+ where

202+ deref r@(Ref (Reference name))

203+ | p name =

204+ case HashMap.lookup name defs of

205+ Just schema -> Inline (inlineSchemasWhen p defs schema)

206+ Nothing -> r

207+ | otherwise = r

208+ deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)

209+

210+-- | Inline any referenced schema if its name is in the given list.

211+--

212+-- /NOTE:/ if a referenced schema is not found in definitions

213+-- it stays referenced even if it appears in the list of names.

214+--

215+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas

216+-- when inlining recursive schemas.

217+inlineSchemas :: Data s => [T.Text] -> Definitions -> s -> s

218+inlineSchemas names = inlineSchemasWhen (`elem` names)

219+

220+-- | Inline all schema references for which the definition

221+-- can be found in @'Definitions'@.

222+--

223+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas

224+-- when inlining recursive schemas.

225+inlineAllSchemas :: Data s => Definitions -> s -> s

226+inlineAllSchemas = inlineSchemasWhen (const True)

227+

228+-- | Convert a type into a schema without references.

229+--

230+-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])

231+-- "{\"items\":{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"},\"type\":\"array\"}"

232+--

233+-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema

234+-- when inlining recursive schemas.

235+toInlinedSchema :: ToSchema a => proxy a -> Schema

236+toInlinedSchema proxy = inlineAllSchemas defs schema

237+ where

238+ (defs, schema) = runDeclare (declareSchema proxy) mempty

239+

240+-- | Inline all /non-recursive/ schemas for which the definition

241+-- can be found in @'Definitions'@.

242+inlineNonRecursiveSchemas :: Data s => Definitions -> s -> s

243+inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

244+ where

245+ nonRecursive name =

246+ case HashMap.lookup name defs of

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

248+ Nothing -> False

249+

250+ usedNames schema = traverse_ schemaRefNames (schema ^.. template)

251+

252+ schemaRefNames :: Referenced Schema -> Declare [T.Text] ()

253+ schemaRefNames ref = case ref of

254+ Ref (Reference name) -> do

255+ seen <- looks (name `elem`)

256+ when (not seen) $ do

257+ declare [name]

258+ traverse_ usedNames (HashMap.lookup name defs)

259+ Inline subschema -> usedNames subschema

260+

164261class GToSchema (f :: * -> *) where

165262 gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema

166263

@@ -207,7 +304,6 @@ timeSchema :: T.Text -> Schema

207304timeSchema format = mempty

208305 & schemaType .~ SwaggerString

209306 & schemaFormat ?~ format

210− & schemaMinLength ?~ toInteger (T.length format)

211307

212308-- |

213309-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat

@@ -226,7 +322,6 @@ instance ToSchema LocalTime where

226322-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"

227323instance ToSchema ZonedTime where

228324 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"

229− & schemaMinLength ?~ toInteger (T.length "yyyy-mm-ddThh:MM:ssZ")

230325

231326instance ToSchema NominalDiffTime where

232327 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)

src/Data/Swagger/Internal/Utils.hs+7

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

11{-# LANGUAGE DefaultSignatures #-}

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

45{-# LANGUAGE TypeOperators #-}

56module Data.Swagger.Internal.Utils where

@@ -10,6 +11,7 @@ import Data.Aeson

1011import Data.Aeson.TH

1112import Data.Aeson.Types (Parser, Pair)

1213import Data.Char

14+import Data.Data

1315import Data.Hashable (Hashable)

1416import Data.HashMap.Strict (HashMap)

1517import qualified Data.HashMap.Strict as HashMap

@@ -19,6 +21,11 @@ import GHC.Generics

1921import Language.Haskell.TH

2022import Text.Read (readMaybe)

2123

24+gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a

25+gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of

26+ Just x -> z x

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

28+

2229hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v

2330hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList

2431

src/Data/Swagger/Schema.hs+7

@@ -16,6 +16,7 @@ module Data.Swagger.Schema (

1616 toSchema,

1717 toSchemaRef,

1818 schemaName,

19+ toInlinedSchema,

1920

2021 -- * Generic schema encoding

2122 genericDeclareNamedSchema,

@@ -25,6 +26,12 @@ module Data.Swagger.Schema (

2526 paramSchemaToNamedSchema,

2627 paramSchemaToSchema,

2728

29+ -- * Inlining @'Schema'@s

30+ inlineNonRecursiveSchemas,

31+ inlineAllSchemas,

32+ inlineSchemas,

33+ inlineSchemasWhen,

34+

2835 -- * Generic encoding configuration

2936 SchemaOptions(..),

3037 defaultSchemaOptions,

src/Data/Swagger/SchemaOptions.hs−18

@@ -11,22 +11,6 @@ data SchemaOptions = SchemaOptions

1111 -- | If @'True'@ the constructors of a datatype, with all nullary constructors,

1212 -- will be encoded to a string enumeration schema with the constructor tags as possible values.

1313 , allNullaryToStringTag :: Bool

14− -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).

15− -- Note that this option does not influence nested schemas, e.g. for these types

16− --

17− -- @

18− -- data Object = Object String deriving Generic

19− -- instance ToSchema Object

20− --

21− -- newtype Objects = Objects [Object] deriving Generic

22− -- instance ToSchema Objects where

23− -- toNamedSchema = genericToNamedSchema defaultSchemaOptions

24− -- { useReferences = False }

25− -- @

26− --

27− -- Schema for @Objects@ __will not__ inline @Object@ schema because

28− -- it is nested in a @[]@ schema.

29− , useReferences :: Bool

3014 -- | Hide the field name when a record constructor has only one field, like a newtype.

3115 , unwrapUnaryRecords :: Bool

3216 }

@@ -39,7 +23,6 @@ data SchemaOptions = SchemaOptions

3923-- , 'constructorTagModifier' = id

4024-- , 'datatypeNameModifier' = id

4125-- , 'allNullaryToStringTag' = True

42−-- , 'useReferences' = True

4326-- , 'unwrapUnaryRecords' = False

4427-- }

4528-- @

@@ -49,7 +32,6 @@ defaultSchemaOptions = SchemaOptions

4932 , constructorTagModifier = id

5033 , datatypeNameModifier = id

5134 , allNullaryToStringTag = True

52− , useReferences = True

5335 , unwrapUnaryRecords = False

5436 }

5537

test/Data/Swagger/SchemaSpec.hs+137

@@ -37,6 +37,19 @@ checkDefs proxy names =

3737 where

3838 defs = execDeclare (declareNamedSchema proxy) mempty

3939

40+checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec

41+checkInlinedSchema proxy js = toInlinedSchema proxy <=> js

42+

43+checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec

44+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs schema <=> js

45+ where

46+ (defs, schema) = runDeclare (declareSchema proxy) mempty

47+

48+checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec

49+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs schema <=> js

50+ where

51+ (defs, schema) = runDeclare (declareSchema proxy) mempty

52+

4053spec :: Spec

4154spec = do

4255 describe "Generic ToSchema" $ do

@@ -70,6 +83,12 @@ spec = do

7083 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

7184 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

7285 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

86+ describe "Inlining Schemas" $ do

87+ context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON

88+ context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON

89+ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

90+ context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

91+ context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

7392

7493main :: IO ()

7594main = hspec spec

@@ -196,6 +215,22 @@ paintSchemaJSON = [aesonQQ|

196215}

197216|]

198217

218+paintInlinedSchemaJSON :: Value

219+paintInlinedSchemaJSON = [aesonQQ|

220+{

221+ "type": "object",

222+ "properties":

223+ {

224+ "color":

225+ {

226+ "type": "string",

227+ "enum": ["Red", "Green", "Blue"]

228+ }

229+ },

230+ "required": ["color"]

231+}

232+|]

233+

199234-- ========================================================================

200235-- Email (newtype with unwrapUnaryRecords set to True)

201236-- ========================================================================

@@ -407,6 +442,89 @@ characterSchemaJSON = [aesonQQ|

407442}

408443|]

409444

445+characterInlinedSchemaJSON :: Value

446+characterInlinedSchemaJSON = [aesonQQ|

447+{

448+ "type": "object",

449+ "properties":

450+ {

451+ "PC":

452+ {

453+ "type": "object",

454+ "properties":

455+ {

456+ "position":

457+ {

458+ "type": "object",

459+ "properties":

460+ {

461+ "x": { "type": "number" },

462+ "y": { "type": "number" }

463+ },

464+ "required": ["x", "y"]

465+ }

466+ },

467+ "required": ["position"]

468+ },

469+ "NPC":

470+ {

471+ "type": "object",

472+ "properties":

473+ {

474+ "npcName": { "type": "string" },

475+ "npcPosition":

476+ {

477+ "type": "object",

478+ "properties":

479+ {

480+ "x": { "type": "number" },

481+ "y": { "type": "number" }

482+ },

483+ "required": ["x", "y"]

484+ }

485+ },

486+ "required": ["npcName", "npcPosition"]

487+ }

488+ },

489+ "maxProperties": 1,

490+ "minProperties": 1

491+}

492+|]

493+

494+characterInlinedPlayerSchemaJSON :: Value

495+characterInlinedPlayerSchemaJSON = [aesonQQ|

496+{

497+ "type": "object",

498+ "properties":

499+ {

500+ "PC":

501+ {

502+ "type": "object",

503+ "properties":

504+ {

505+ "position":

506+ {

507+ "$ref": "#/definitions/Point"

508+ }

509+ },

510+ "required": ["position"]

511+ },

512+ "NPC":

513+ {

514+ "type": "object",

515+ "properties":

516+ {

517+ "npcName": { "type": "string" },

518+ "npcPosition": { "$ref": "#/definitions/Point" }

519+ },

520+ "required": ["npcName", "npcPosition"]

521+ }

522+ },

523+ "maxProperties": 1,

524+ "minProperties": 1

525+}

526+|]

527+

410528-- ========================================================================

411529-- Light (sum type with unwrapUnaryRecords)

412530-- ========================================================================

@@ -436,3 +554,22 @@ lightSchemaJSON = [aesonQQ|

436554}

437555|]

438556

557+lightInlinedSchemaJSON :: Value

558+lightInlinedSchemaJSON = [aesonQQ|

559+{

560+ "type": "object",

561+ "properties":

562+ {

563+ "LightFreq": { "type": "number" },

564+ "LightColor":

565+ {

566+ "type": "string",

567+ "enum": ["Red", "Green", "Blue"]

568+ },

569+ "LightWaveLength": { "type": "number" }

570+ },

571+ "maxProperties": 1,

572+ "minProperties": 1

573+}

574+|]

575+