0eb35c7 · typeable/swagger2

git.iko.soy/typeable/swagger2

on master help sign in

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

0eb35c7Nickolay Kudasov11 years ago

.travis.yml+1−1

compare with master

unifiedsplit

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

29script:

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

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

33 - cabal test

34 - cabal check

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

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

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

1+{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveTraversable #-}

3{-# LANGUAGE DeriveTraversable #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

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

16import Data.Aeson

17import Data.Aeson

17import Data.Aeson.TH (deriveJSON)

18import Data.Aeson.TH (deriveJSON)

18import qualified Data.Aeson.Types as JSON

19import qualified Data.Aeson.Types as JSON

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

19import Data.HashMap.Strict (HashMap)

21import Data.HashMap.Strict (HashMap)

20import qualified Data.HashMap.Strict as HashMap

22import qualified Data.HashMap.Strict as HashMap

21import Data.Map (Map)

23import Data.Map (Map)

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

92 -- | Additional external documentation.

94 -- | Additional external documentation.

93 , _externalDocs :: Maybe ExternalDocs

95 , _externalDocs :: Maybe ExternalDocs

94− } deriving (Eq, Show, Generic)

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

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

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

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

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

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

116 -- | Provides the version of the application API

118 -- | Provides the version of the application API

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

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

118 , _infoVersion :: Text

120 , _infoVersion :: Text

119− } deriving (Eq, Show, Generic)

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

120

122

121-- | Contact information for the exposed API.

123-- | Contact information for the exposed API.

122data Contact = Contact

124data Contact = Contact

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

128

130

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

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

130 , _contactEmail :: Maybe Text

132 , _contactEmail :: Maybe Text

131− } deriving (Eq, Show)

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

132

134

133-- | License information for the exposed API.

135-- | License information for the exposed API.

134data License = License

136data License = License

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

137

139

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

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

139 , _licenseUrl :: Maybe URL

141 , _licenseUrl :: Maybe URL

140− } deriving (Eq, Show)

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

141

143

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

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

143data Host = Host

145data Host = Host

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

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

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

147 , _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

147

162

148-- | The transfer protocol of the API.

163-- | The transfer protocol of the API.

149data Scheme

164data Scheme

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

151 | Https

166 | Https

152 | Ws

167 | Ws

153 | Wss

168 | Wss

154− deriving (Eq, Show)

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

155

170

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

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

157data Paths = Paths

172data Paths = Paths

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

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

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

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

160 _pathsMap :: HashMap FilePath PathItem

175 _pathsMap :: HashMap FilePath PathItem

161− } deriving (Eq, Show, Generic)

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

162

177

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

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

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

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

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

191 -- The list MUST NOT include duplicated parameters.

206 -- The list MUST NOT include duplicated parameters.

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

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

193 , _pathItemParameters :: [Referenced Param]

208 , _pathItemParameters :: [Referenced Param]

194− } deriving (Eq, Show, Generic)

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

195

210

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

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

197data Operation = Operation

212data Operation = Operation

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

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

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

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

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

253 , _operationSecurity :: [SecurityRequirement]

268 , _operationSecurity :: [SecurityRequirement]

254− } deriving (Eq, Show, Generic)

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

255

270

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

271newtype 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

258

286

259-- | Describes a single operation parameter.

287-- | Describes a single operation parameter.

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

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

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

275

303

276 -- | Parameter schema.

304 -- | Parameter schema.

277 , _paramSchema :: ParamAnySchema

305 , _paramSchema :: ParamAnySchema

278− } deriving (Eq, Show, Generic)

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

279

307

280data ParamAnySchema

308data ParamAnySchema

281 = ParamBody (Referenced Schema)

309 = ParamBody (Referenced Schema)

282 | ParamOther ParamOtherSchema

310 | ParamOther ParamOtherSchema

283− deriving (Eq, Show)

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

284

312

285data ParamOtherSchema = ParamOtherSchema

313data ParamOtherSchema = ParamOtherSchema

286 { -- | The location of the parameter.

314 { -- | The location of the parameter.

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

297 , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)

325 , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)

298

326

299 , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items

327 , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items

300− } deriving (Eq, Show, Generic)

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

301

329

302data SwaggerType t where

330data SwaggerType t where

303 SwaggerString :: SwaggerType t

331 SwaggerString :: SwaggerType t

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

311

339

312deriving instance Eq (SwaggerType t)

340deriving instance Eq (SwaggerType t)

313deriving instance Show (SwaggerType t)

341deriving 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

314

377

315data ParamLocation

378data ParamLocation

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

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

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

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

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

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

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

332 | ParamFormData

395 | ParamFormData

333− deriving (Eq, Show)

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

334

397

335type Format = Text

398type Format = Text

336

399

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

351

414

352deriving instance Eq (CollectionFormat t)

415deriving instance Eq (CollectionFormat t)

353deriving instance Show (CollectionFormat t)

416deriving 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)

354

435

355type ParamName = Text

436type ParamName = Text

356

437

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

373 , _schemaMinProperties :: Maybe Integer

454 , _schemaMinProperties :: Maybe Integer

374

455

375 , _schemaParamSchema :: ParamSchema Schema SchemaItems

456 , _schemaParamSchema :: ParamSchema Schema SchemaItems

376− } deriving (Eq, Show, Generic)

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

377

458

378data SchemaItems

459data SchemaItems

379 = SchemaItemsObject (Referenced Schema)

460 = SchemaItemsObject (Referenced Schema)

380 | SchemaItemsArray [Referenced Schema]

461 | SchemaItemsArray [Referenced Schema]

381− deriving (Eq, Show)

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

382

463

383data ParamSchema t items = ParamSchema

464data ParamSchema t items = ParamSchema

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

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

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

403 , _paramSchemaUniqueItems :: Maybe Bool

484 , _paramSchemaUniqueItems :: Maybe Bool

404 , _paramSchemaEnum :: Maybe [Value]

485 , _paramSchemaEnum :: Maybe [Value]

405 , _paramSchemaMultipleOf :: Maybe Scientific

486 , _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)

407

490

408data Xml = Xml

491data Xml = Xml

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

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

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

431 -- Default value is @False@.

514 -- Default value is @False@.

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

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

433 , _xmlWrapped :: Maybe Bool

516 , _xmlWrapped :: Maybe Bool

434− } deriving (Eq, Show, Generic)

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

435

518

436data Items = Items

519data Items = Items

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

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

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

439 _itemsCollectionFormat :: Maybe (CollectionFormat Items)

522 _itemsCollectionFormat :: Maybe (CollectionFormat Items)

440

523

441 , _itemsParamSchema :: ParamSchema Items Items

524 , _itemsParamSchema :: ParamSchema Items Items

442− } deriving (Eq, Show, Generic)

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

443

526

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

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

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

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

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

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

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

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

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

456 , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)

539 , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)

457− } deriving (Eq, Show, Generic)

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

458

541

459type HttpStatusCode = Int

542type HttpStatusCode = Int

460

543

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

476

559

477 -- | An example of the response message.

560 -- | An example of the response message.

478 , _responseExamples :: Maybe Example

561 , _responseExamples :: Maybe Example

479− } deriving (Eq, Show, Generic)

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

480

563

481type HeaderName = Text

564type HeaderName = Text

482

565

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

489 , _headerCollectionFormat :: Maybe (CollectionFormat Items)

572 , _headerCollectionFormat :: Maybe (CollectionFormat Items)

490

573

491 , _headerParamSchema :: ParamSchema Header Items

574 , _headerParamSchema :: ParamSchema Header Items

492− } deriving (Eq, Show, Generic)

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

493

576

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

577data 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

496

592

497-- | The location of the API key.

593-- | The location of the API key.

498data ApiKeyLocation

594data ApiKeyLocation

499 = ApiKeyQuery

595 = ApiKeyQuery

500 | ApiKeyHeader

596 | ApiKeyHeader

501− deriving (Eq, Show)

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

502

598

503data ApiKeyParams = ApiKeyParams

599data ApiKeyParams = ApiKeyParams

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

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

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

506

602

507 -- | The location of the API key.

603 -- | The location of the API key.

508 , _apiKeyIn :: ApiKeyLocation

604 , _apiKeyIn :: ApiKeyLocation

509− } deriving (Eq, Show)

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

510

606

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

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

512type AuthorizationURL = Text

608type AuthorizationURL = Text

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

519 | OAuth2Password TokenURL

615 | OAuth2Password TokenURL

520 | OAuth2Application TokenURL

616 | OAuth2Application TokenURL

521 | OAuth2AccessCode AuthorizationURL TokenURL

617 | OAuth2AccessCode AuthorizationURL TokenURL

522− deriving (Eq, Show)

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

523

619

524data OAuth2Params = OAuth2Params

620data OAuth2Params = OAuth2Params

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

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

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

527

623

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

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

529 , _oauth2Scopes :: HashMap Text Text

625 , _oauth2Scopes :: HashMap Text Text

530− } deriving (Eq, Show, Generic)

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

531

627

532data SecuritySchemeType

628data SecuritySchemeType

533 = SecuritySchemeBasic

629 = SecuritySchemeBasic

534 | SecuritySchemeApiKey ApiKeyParams

630 | SecuritySchemeApiKey ApiKeyParams

535 | SecuritySchemeOAuth2 OAuth2Params

631 | SecuritySchemeOAuth2 OAuth2Params

536− deriving (Eq, Show)

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

537

633

538data SecurityScheme = SecurityScheme

634data SecurityScheme = SecurityScheme

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

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

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

541

637

542 -- | A short description for security scheme.

638 -- | A short description for security scheme.

543 , _securitySchemeDescription :: Maybe Text

639 , _securitySchemeDescription :: Maybe Text

544− } deriving (Eq, Show, Generic)

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

545

641

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

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

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

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

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

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

549newtype SecurityRequirement = SecurityRequirement

645newtype SecurityRequirement = SecurityRequirement

550 { getSecurityRequirement :: HashMap Text [Text]

646 { getSecurityRequirement :: HashMap Text [Text]

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

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

552

648

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

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

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

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

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

562

658

563 -- | Additional external documentation for this tag.

659 -- | Additional external documentation for this tag.

564 , _tagExternalDocs :: Maybe ExternalDocs

660 , _tagExternalDocs :: Maybe ExternalDocs

565− } deriving (Eq, Show)

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

566

662

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

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

568data ExternalDocs = ExternalDocs

664data ExternalDocs = ExternalDocs

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

572

668

573 -- | The URL for the target documentation.

669 -- | The URL for the target documentation.

574 , _externalDocsUrl :: URL

670 , _externalDocsUrl :: URL

575− } deriving (Eq, Show, Generic)

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

576

672

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

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

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

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

579newtype Reference = Reference { getReference :: Text }

675newtype Reference = Reference { getReference :: Text }

580− deriving (Eq, Show)

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

581

677

582data Referenced a

678data Referenced a

583 = Ref Reference

679 = Ref Reference

584 | Inline a

680 | Inline a

585− deriving (Eq, Show)

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

586

682

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

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

588

684

589-- =======================================================================

685-- =======================================================================

590-- Monoid instances

686-- Monoid instances

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

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

14module Data.Swagger.Internal.Schema where

16import Control.Lens

17+import Data.Data.Lens (template)

18+

17import Control.Monad

19import Control.Monad

18import Control.Monad.Writer

20import Control.Monad.Writer

19import Data.Aeson

21import Data.Aeson

20import Data.Char

22import Data.Char

23+import Data.Data (Data)

24+import Data.Foldable (traverse_)

21import Data.HashMap.Strict (HashMap)

25import Data.HashMap.Strict (HashMap)

22import qualified Data.HashMap.Strict as HashMap

26import qualified Data.HashMap.Strict as HashMap

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

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

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

119declareSchema = fmap snd . declareNamedSchema

123declareSchema = fmap snd . declareNamedSchema

120

124

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

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

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

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

123toNamedSchema = undeclare . declareNamedSchema

133toNamedSchema = undeclare . declareNamedSchema

124

134

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

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

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

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

127schemaName = fst . toNamedSchema

143schemaName = fst . toNamedSchema

128

144

129-- | Convert a type into a schema.

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

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

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

131toSchema = snd . toNamedSchema

153toSchema = snd . toNamedSchema

132

154

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

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

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

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

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

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

136toSchemaRef = undeclare . declareSchemaRef

164toSchemaRef = undeclare . declareSchemaRef

137

165

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

161 return $ Ref (Reference name)

189 return $ Ref (Reference name)

162 _ -> Inline <$> declareSchema proxy

190 _ -> Inline <$> declareSchema proxy

163

191

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+

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

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

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

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

166

263

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

207timeSchema format = mempty

304timeSchema format = mempty

208 & schemaType .~ SwaggerString

305 & schemaType .~ SwaggerString

209 & schemaFormat ?~ format

306 & schemaFormat ?~ format

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

211

307

212-- |

308-- |

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

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

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

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

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

227instance ToSchema ZonedTime where

323instance ToSchema ZonedTime where

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

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

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

230

325

231instance ToSchema NominalDiffTime where

326instance ToSchema NominalDiffTime where

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

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

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

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

1{-# LANGUAGE DefaultSignatures #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5module Data.Swagger.Internal.Utils where

6module Data.Swagger.Internal.Utils where

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

10import Data.Aeson.TH

11import Data.Aeson.TH

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

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

12import Data.Char

13import Data.Char

14+import Data.Data

13import Data.Hashable (Hashable)

15import Data.Hashable (Hashable)

14import Data.HashMap.Strict (HashMap)

16import Data.HashMap.Strict (HashMap)

15import qualified Data.HashMap.Strict as HashMap

17import qualified Data.HashMap.Strict as HashMap

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

19import Language.Haskell.TH

21import Language.Haskell.TH

20import Text.Read (readMaybe)

22import Text.Read (readMaybe)

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+

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

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

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

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

src/Data/Swagger/Schema.hs+7

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

16 toSchema,

17 toSchemaRef,

18 schemaName,

19+ toInlinedSchema,

20 -- * Generic schema encoding

21 -- * Generic schema encoding

21 genericDeclareNamedSchema,

22 genericDeclareNamedSchema,

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

25 paramSchemaToNamedSchema,

26 paramSchemaToNamedSchema,

26 paramSchemaToSchema,

27 paramSchemaToSchema,

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

30+ inlineNonRecursiveSchemas,

31+ inlineAllSchemas,

32+ inlineSchemas,

33+ inlineSchemasWhen,

34+

28 -- * Generic encoding configuration

35 -- * Generic encoding configuration

29 SchemaOptions(..),

36 SchemaOptions(..),

30 defaultSchemaOptions,

37 defaultSchemaOptions,

src/Data/Swagger/SchemaOptions.hs−18

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

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

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

13 , 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

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

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

31 , unwrapUnaryRecords :: Bool

15 , unwrapUnaryRecords :: Bool

32 }

16 }

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

39-- , 'constructorTagModifier' = id

23-- , 'constructorTagModifier' = id

40-- , 'datatypeNameModifier' = id

24-- , 'datatypeNameModifier' = id

41-- , 'allNullaryToStringTag' = True

25-- , 'allNullaryToStringTag' = True

42−-- , 'useReferences' = True

43-- , 'unwrapUnaryRecords' = False

26-- , 'unwrapUnaryRecords' = False

44-- }

27-- }

45-- @

28-- @

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

49 , constructorTagModifier = id

32 , constructorTagModifier = id

50 , datatypeNameModifier = id

33 , datatypeNameModifier = id

51 , allNullaryToStringTag = True

34 , allNullaryToStringTag = True

52− , useReferences = True

53 , unwrapUnaryRecords = False

35 , unwrapUnaryRecords = False

54 }

36 }

test/Data/Swagger/SchemaSpec.hs+137

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

37 where

38 defs = execDeclare (declareNamedSchema proxy) mempty

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+

40spec :: Spec

53spec :: Spec

41spec = do

54spec = do

42 describe "Generic ToSchema" $ do

55 describe "Generic ToSchema" $ do

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

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

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

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

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

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

85 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

74main :: IO ()

93main :: IO ()

75main = hspec spec

94main = hspec spec

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

196}

215}

197|]

216|]

198

217

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+

199-- ========================================================================

234-- ========================================================================

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

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

201-- ========================================================================

236-- ========================================================================

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

407}

442}

408|]

443|]

409

444

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+

410-- ========================================================================

528-- ========================================================================

411-- Light (sum type with unwrapUnaryRecords)

529-- Light (sum type with unwrapUnaryRecords)

412-- ========================================================================

530-- ========================================================================

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

436}

554}

437|]

555|]

438

556

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+