3f343ca · typeable/openapi3

git.iko.soy/typeable/openapi3

on master help sign in

Add FromJSON instances

3f343caNickolay Kudasov11 years ago

src/Data/Swagger/Internal.hs+184−63

compare with master

unifiedsplit

@@ -3,20 +3,28 @@

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE RecordWildCards #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE TemplateHaskell #-}

7{-# LANGUAGE TemplateHaskell #-}

7module Data.Swagger.Internal where

8module Data.Swagger.Internal where

10+import Control.Applicative

11+import Control.Monad

9import Data.Aeson

12import Data.Aeson

10−import Data.Aeson.TH (deriveToJSON)

13+import Data.Aeson.TH (deriveJSON)

11import Data.Foldable (Foldable)

14import Data.Foldable (Foldable)

12import Data.HashMap.Strict (HashMap)

15import Data.HashMap.Strict (HashMap)

13import qualified Data.HashMap.Strict as HashMap

16import qualified Data.HashMap.Strict as HashMap

17+import Data.Map (Map)

18+import qualified Data.Map as Map

19+import Data.String (fromString)

14import Data.Text (Text)

20import Data.Text (Text)

21+import qualified Data.Text as Text

15import Data.Traversable (Traversable)

22import Data.Traversable (Traversable)

16import Data.Hashable (Hashable)

23import Data.Hashable (Hashable)

17import GHC.Generics (Generic)

24import GHC.Generics (Generic)

18import Network (HostName, PortNumber)

25import Network (HostName, PortNumber)

19import Network.HTTP.Media (MediaType)

26import Network.HTTP.Media (MediaType)

27+import Text.Read (readMaybe)

21import Data.Swagger.Internal.Utils

29import Data.Swagger.Internal.Utils

@@ -133,12 +141,6 @@ data SwaggerHost = SwaggerHost

133 , swaggerHostPort :: Maybe PortNumber -- ^ Optional port.

141 , swaggerHostPort :: Maybe PortNumber -- ^ Optional port.

134 } deriving (Show)

142 } deriving (Show)

135

143

136−instance ToJSON SwaggerHost where

137− toJSON (SwaggerHost host mport) = toJSON $

138− case mport of

139− Nothing -> host

140− Just port -> host ++ ":" ++ show port

141−

142-- | The transfer protocol of the API.

144-- | The transfer protocol of the API.

143data SwaggerScheme

145data SwaggerScheme

144 = Http

146 = Http

@@ -154,9 +156,6 @@ data SwaggerPaths = SwaggerPaths

154 swaggerPathsMap :: HashMap FilePath SwaggerPathItem

156 swaggerPathsMap :: HashMap FilePath SwaggerPathItem

155 } deriving (Show)

157 } deriving (Show)

156

158

157−instance ToJSON SwaggerPaths where

158− toJSON (SwaggerPaths m) = toJSON m

159−

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

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

161-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.

160-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.

162-- The path itself is still exposed to the documentation viewer

161-- The path itself is still exposed to the documentation viewer

@@ -253,9 +252,6 @@ data SwaggerOperation = SwaggerOperation

253newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }

252newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] }

254 deriving (Show)

253 deriving (Show)

255

254

256−instance ToJSON SwaggerMimeList where

257− toJSON (SwaggerMimeList xs) = toJSON (map show xs)

258−

259-- | Describes a single operation parameter.

255-- | Describes a single operation parameter.

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

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

261data SwaggerParameter = SwaggerParameter

257data SwaggerParameter = SwaggerParameter

@@ -277,18 +273,11 @@ data SwaggerParameter = SwaggerParameter

277 , swaggerParameterSchema :: SwaggerParameterSchema

273 , swaggerParameterSchema :: SwaggerParameterSchema

278 } deriving (Show, Generic)

274 } deriving (Show, Generic)

279

275

280−instance ToJSON SwaggerParameter where

281− toJSON = genericToJSONWithSub "schema" (jsonPrefix "swaggerParameter")

282−

283data SwaggerParameterSchema

276data SwaggerParameterSchema

284 = SwaggerParameterBody SwaggerSchema

277 = SwaggerParameterBody SwaggerSchema

285 | SwaggerParameterOther SwaggerParameterOtherSchema

278 | SwaggerParameterOther SwaggerParameterOtherSchema

286 deriving (Show)

279 deriving (Show)

287

280

288−instance ToJSON SwaggerParameterSchema where

289− toJSON (SwaggerParameterBody s) = toJSON s <+> object [ "in" .= ("body" :: Text) ]

290− toJSON (SwaggerParameterOther s) = toJSON s

291−

292data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema

281data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema

293 { -- | The location of the parameter.

282 { -- | The location of the parameter.

294 swaggerParameterOtherSchemaIn :: SwaggerParameterLocation

283 swaggerParameterOtherSchemaIn :: SwaggerParameterLocation

@@ -321,9 +310,6 @@ data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema

321 , swaggerParameterOtherSchemaCommon :: SwaggerSchemaCommon

310 , swaggerParameterOtherSchemaCommon :: SwaggerSchemaCommon

322 } deriving (Show, Generic)

311 } deriving (Show, Generic)

323

312

324−instance ToJSON SwaggerParameterOtherSchema where

325− toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")

326−

327data SwaggerParameterType

313data SwaggerParameterType

328 = SwaggerParamString

314 = SwaggerParamString

329 | SwaggerParamNumber

315 | SwaggerParamNumber

@@ -421,10 +407,6 @@ data SwaggerSchemaItems

421 | SwaggerSchemaItemsArray [SwaggerSchema]

407 | SwaggerSchemaItemsArray [SwaggerSchema]

422 deriving (Show)

408 deriving (Show)

423

409

424−instance ToJSON SwaggerSchemaItems where

425− toJSON (SwaggerSchemaItemsObject x) = toJSON x

426− toJSON (SwaggerSchemaItemsArray xs) = toJSON xs

427−

428data SwaggerSchemaCommon = SwaggerSchemaCommon

410data SwaggerSchemaCommon = SwaggerSchemaCommon

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

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

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

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

@@ -508,11 +490,6 @@ data SwaggerResponses = SwaggerResponses

508 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse

490 , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse

509 } deriving (Show)

491 } deriving (Show)

510

492

511−instance ToJSON SwaggerResponses where

512− toJSON (SwaggerResponses def rs) = object

513− [ "default" .= def

514− , "responses" .= hashMapMapKeys show rs ]

515−

516type HttpStatusCode = Int

493type HttpStatusCode = Int

517

494

518-- | Describes a single response from an API Operation.

495-- | Describes a single response from an API Operation.

@@ -558,12 +535,9 @@ data SwaggerHeader = SwaggerHeader

558 , swaggerHeaderCommon :: SwaggerSchemaCommon

535 , swaggerHeaderCommon :: SwaggerSchemaCommon

559 } deriving (Show, Generic)

536 } deriving (Show, Generic)

560

537

561−data SwaggerExample = SwaggerExample { getSwaggerExample :: HashMap MediaType Value }

538+data SwaggerExample = SwaggerExample { getSwaggerExample :: Map MediaType Value }

562 deriving (Show)

539 deriving (Show)

563

540

564−instance ToJSON SwaggerExample where

565− toJSON = toJSON . hashMapMapKeys show . getSwaggerExample

566−

567-- | The location of the API key.

541-- | The location of the API key.

568data SwaggerApiKeyLocation

542data SwaggerApiKeyLocation

569 = SwaggerApiKeyQuery

543 = SwaggerApiKeyQuery

@@ -611,10 +585,16 @@ data SwaggerSecuritySchemeTypeName

611 | SwaggerSecuritySchemeTypeOAuth2

585 | SwaggerSecuritySchemeTypeOAuth2

612 deriving (Eq, Read, Show, Generic)

586 deriving (Eq, Read, Show, Generic)

613

587

614−swaggerSecuritySchemeTypeNameText :: SwaggerSecuritySchemeTypeName -> Text

588+swaggerSecuritySchemeTypeNameToText :: SwaggerSecuritySchemeTypeName -> Text

615−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeBasic = "basic"

589+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeBasic = "basic"

616−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeApiKey = "apiKey"

590+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeApiKey = "apiKey"

617−swaggerSecuritySchemeTypeNameText SwaggerSecuritySchemeTypeOAuth2 = "oauth2"

591+swaggerSecuritySchemeTypeNameToText SwaggerSecuritySchemeTypeOAuth2 = "oauth2"

592+

593+swaggerSecuritySchemeTypeNameFromText :: Alternative f => Text -> f SwaggerSecuritySchemeTypeName

594+swaggerSecuritySchemeTypeNameFromText "basic" = pure SwaggerSecuritySchemeTypeBasic

595+swaggerSecuritySchemeTypeNameFromText "apiKey" = pure SwaggerSecuritySchemeTypeApiKey

596+swaggerSecuritySchemeTypeNameFromText "oauth2" = pure SwaggerSecuritySchemeTypeOAuth2

597+swaggerSecuritySchemeTypeNameFromText _ = empty

618

598

619instance Hashable SwaggerSecuritySchemeTypeName

599instance Hashable SwaggerSecuritySchemeTypeName

620

600

@@ -633,9 +613,6 @@ newtype SwaggerSecurityRequirement = SwaggerSecurityRequirement

633 { getSwaggerSecurityRequirement :: HashMap SwaggerSecuritySchemeTypeName Text

613 { getSwaggerSecurityRequirement :: HashMap SwaggerSecuritySchemeTypeName Text

634 } deriving (Eq, Read, Show, Monoid)

614 } deriving (Eq, Read, Show, Monoid)

635

615

636−instance ToJSON SwaggerSecurityRequirement where

637− toJSON (SwaggerSecurityRequirement m) = toJSON (hashMapMapKeys swaggerSecuritySchemeTypeNameText m)

638−

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

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

640-- It is not mandatory to have a @SwaggerTag@ per tag used there.

617-- It is not mandatory to have a @SwaggerTag@ per tag used there.

641data SwaggerTag = SwaggerTag

618data SwaggerTag = SwaggerTag

@@ -662,26 +639,34 @@ data SwaggerExternalDocs = SwaggerExternalDocs

662

639

663newtype URL = URL { getUrl :: Text } deriving (Show, ToJSON, FromJSON)

640newtype URL = URL { getUrl :: Text } deriving (Show, ToJSON, FromJSON)

664

641

642+-- =======================================================================

643+-- TH derived ToJSON and FromJSON instances

644+-- =======================================================================

645+

665−deriveToJSON' ''SwaggerOperation

646+deriveJSON' ''SwaggerOperation

666−deriveToJSON (jsonPrefix "SwaggerParameter") ''SwaggerParameterLocation

647+deriveJSON (jsonPrefix "SwaggerParameter") ''SwaggerParameterLocation

667−deriveToJSON (jsonPrefix "SwaggerParam") ''SwaggerParameterType

648+deriveJSON (jsonPrefix "SwaggerParam") ''SwaggerParameterType

668−deriveToJSON' ''SwaggerPathItem

649+deriveJSON' ''SwaggerPathItem

669−deriveToJSON' ''SwaggerInfo

650+deriveJSON' ''SwaggerInfo

670−deriveToJSON' ''SwaggerContact

651+deriveJSON' ''SwaggerContact

671−deriveToJSON' ''SwaggerLicense

652+deriveJSON' ''SwaggerLicense

672−deriveToJSON (jsonPrefix "SwaggerSchema") ''SwaggerSchemaType

653+deriveJSON (jsonPrefix "SwaggerSchema") ''SwaggerSchemaType

673−deriveToJSON (jsonPrefix "SwaggerItems") ''SwaggerItemsType

654+deriveJSON (jsonPrefix "SwaggerItems") ''SwaggerItemsType

674−deriveToJSON (jsonPrefix "SwaggerItemsCollection") ''SwaggerItemsCollectionFormat

655+deriveJSON (jsonPrefix "SwaggerItemsCollection") ''SwaggerItemsCollectionFormat

675−deriveToJSON (jsonPrefix "SwaggerCollection") ''SwaggerCollectionFormat

656+deriveJSON (jsonPrefix "SwaggerCollection") ''SwaggerCollectionFormat

676−deriveToJSON (jsonPrefix "SwaggerSecuritySchemeType") ''SwaggerSecuritySchemeTypeName

657+deriveJSON (jsonPrefix "SwaggerSecuritySchemeType") ''SwaggerSecuritySchemeTypeName

677−deriveToJSON (jsonPrefix "SwaggerApiKey") ''SwaggerApiKeyLocation

658+deriveJSON (jsonPrefix "SwaggerApiKey") ''SwaggerApiKeyLocation

678−deriveToJSON (jsonPrefix "swaggerApiKey") ''SwaggerApiKeyParams

659+deriveJSON (jsonPrefix "swaggerApiKey") ''SwaggerApiKeyParams

679−deriveToJSON' ''SwaggerResponse

660+deriveJSON' ''SwaggerResponse

680−deriveToJSON' ''SwaggerSchemaCommon

661+deriveJSON' ''SwaggerSchemaCommon

681−deriveToJSONDefault ''SwaggerScheme

662+deriveJSONDefault ''SwaggerScheme

682−deriveToJSON' ''SwaggerTag

663+deriveJSON' ''SwaggerTag

683−deriveToJSON' ''SwaggerExternalDocs

664+deriveJSON' ''SwaggerExternalDocs

684−deriveToJSON' ''SwaggerXml

665+deriveJSON' ''SwaggerXml

666+

667+-- =======================================================================

668+-- Manual ToJSON instances

669+-- =======================================================================

685

670

686instance ToJSON SwaggerOAuth2Flow where

671instance ToJSON SwaggerOAuth2Flow where

687 toJSON (SwaggerOAuth2Implicit authUrl) = object

672 toJSON (SwaggerOAuth2Implicit authUrl) = object

@@ -729,3 +714,139 @@ instance ToJSON SwaggerHeader where

729instance ToJSON SwaggerItems where

714instance ToJSON SwaggerItems where

730 toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerItems")

715 toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerItems")

731

716

717+instance ToJSON SwaggerHost where

718+ toJSON (SwaggerHost host mport) = toJSON $

719+ case mport of

720+ Nothing -> host

721+ Just port -> host ++ ":" ++ show port

722+

723+instance ToJSON SwaggerPaths where

724+ toJSON (SwaggerPaths m) = toJSON m

725+

726+instance ToJSON SwaggerMimeList where

727+ toJSON (SwaggerMimeList xs) = toJSON (map show xs)

728+

729+instance ToJSON SwaggerParameter where

730+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "swaggerParameter")

731+

732+instance ToJSON SwaggerParameterSchema where

733+ toJSON (SwaggerParameterBody s) = toJSON s <+> object [ "in" .= ("body" :: Text) ]

734+ toJSON (SwaggerParameterOther s) = toJSON s

735+

736+instance ToJSON SwaggerParameterOtherSchema where

737+ toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")

738+

739+instance ToJSON SwaggerSchemaItems where

740+ toJSON (SwaggerSchemaItemsObject x) = toJSON x

741+ toJSON (SwaggerSchemaItemsArray xs) = toJSON xs

742+

743+instance ToJSON SwaggerResponses where

744+ toJSON (SwaggerResponses def rs) = object

745+ [ "default" .= def

746+ , "responses" .= hashMapMapKeys show rs ]

747+

748+instance ToJSON SwaggerExample where

749+ toJSON = toJSON . Map.mapKeys show . getSwaggerExample

750+

751+instance ToJSON SwaggerSecurityRequirement where

752+ toJSON (SwaggerSecurityRequirement m) = toJSON (hashMapMapKeys swaggerSecuritySchemeTypeNameToText m)

753+

754+-- =======================================================================

755+-- Manual FromJSON instances

756+-- =======================================================================

757+

758+instance FromJSON SwaggerOAuth2Flow where

759+ parseJSON (Object o) = do

760+ (flow :: Text) <- o .: "flow"

761+ case flow of

762+ "implicit" -> SwaggerOAuth2Implicit <$> o .: "authorizationUrl"

763+ "password" -> SwaggerOAuth2Password <$> o .: "tokenUrl"

764+ "application" -> SwaggerOAuth2Application <$> o .: "tokenUrl"

765+ "accessCode" -> SwaggerOAuth2AccessCode

766+ <$> o .: "authorizationUrl"

767+ <*> o .: "tokenUrl"

768+ _ -> empty

769+ parseJSON _ = empty

770+

771+instance FromJSON SwaggerOAuth2Params where

772+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "swaggerOAuth2")

773+

774+instance FromJSON SwaggerSecuritySchemeType where

775+ parseJSON json@(Object o) = do

776+ t <- o .: "type"

777+ case t of

778+ SwaggerSecuritySchemeTypeBasic -> pure SwaggerSecuritySchemeBasic

779+ SwaggerSecuritySchemeTypeApiKey -> SwaggerSecuritySchemeApiKey <$> parseJSON json

780+ SwaggerSecuritySchemeTypeOAuth2 -> SwaggerSecuritySchemeOAuth2 <$> parseJSON json

781+ parseJSON _ = empty

782+

783+instance FromJSON Swagger where

784+ parseJSON json@(Object o) = do

785+ (version :: Text) <- o .: "swagger"

786+ when (version /= "2.0") empty

787+ genericParseJSON (jsonPrefix "swagger") json

788+ parseJSON _ = empty

789+

790+instance FromJSON SwaggerSecurityScheme where

791+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "swaggerSecurityScheme")

792+

793+instance FromJSON SwaggerSchema where

794+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerSchema")

795+

796+instance FromJSON SwaggerHeader where

797+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerHeader")

798+

799+instance FromJSON SwaggerItems where

800+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerItems")

801+

802+instance FromJSON SwaggerHost where

803+ parseJSON (String s) =

804+ case fromInteger <$> readMaybe portStr of

805+ Nothing | not (null portStr) -> empty

806+ mport -> pure $ SwaggerHost host mport

807+ where

808+ (hostText, portText) = Text.breakOnEnd ":" s

809+ [host, portStr] = map Text.unpack [hostText, portText]

810+ parseJSON _ = empty

811+

812+instance FromJSON SwaggerPaths where

813+ parseJSON json = SwaggerPaths <$> parseJSON json

814+

815+instance FromJSON SwaggerMimeList where

816+ parseJSON json = (SwaggerMimeList . map fromString) <$> parseJSON json

817+

818+instance FromJSON SwaggerParameter where

819+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "swaggerParameter")

820+

821+instance FromJSON SwaggerParameterSchema where

822+ parseJSON json@(Object o) = do

823+ (i :: Text) <- o .: "in"

824+ case i of

825+ "body" -> SwaggerParameterBody <$> parseJSON json

826+ _ -> SwaggerParameterOther <$> parseJSON json

827+ parseJSON _ = empty

828+

829+instance FromJSON SwaggerParameterOtherSchema where

830+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema")

831+

832+instance FromJSON SwaggerSchemaItems where

833+ parseJSON json@(Object _) = SwaggerSchemaItemsObject <$> parseJSON json

834+ parseJSON json@(Array _) = SwaggerSchemaItemsArray <$> parseJSON json

835+ parseJSON _ = empty

836+

837+instance FromJSON SwaggerResponses where

838+ parseJSON (Object o) = SwaggerResponses

839+ <$> o .: "default"

840+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)

841+ parseJSON _ = empty

842+

843+instance FromJSON SwaggerExample where

844+ parseJSON json = do

845+ m <- parseJSON json

846+ pure $ SwaggerExample (Map.mapKeys fromString m)

847+

848+instance FromJSON SwaggerSecurityRequirement where

849+ parseJSON json = do

850+ m <- parseJSON json

851+ SwaggerSecurityRequirement <$> hashMapTraverseKeys swaggerSecuritySchemeTypeNameFromText m

852+

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

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

2module Data.Swagger.Internal.Utils where

4import Control.Arrow (first)

5+import Control.Applicative

5import Data.Aeson

6import Data.Aeson

6import Data.Aeson.TH

7import Data.Aeson.TH

7import Data.Aeson.Types (Parser)

8import Data.Aeson.Types (Parser)

@@ -11,12 +12,22 @@ import Data.HashMap.Strict (HashMap)

11import qualified Data.HashMap.Strict as HashMap

12import qualified Data.HashMap.Strict as HashMap

12import Data.Monoid

13import Data.Monoid

13import Data.Text (Text)

14import Data.Text (Text)

15+import Data.Traversable

14import GHC.Generics

16import GHC.Generics

15import Language.Haskell.TH

17import Language.Haskell.TH

18+import Text.Read (readMaybe)

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

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

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

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

23+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)

24+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList

25+ where

26+ g (x, y) = (\a -> (a, y)) <$> f x

27+

28+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)

29+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)

30+

20jsonPrefix :: String -> Options

31jsonPrefix :: String -> Options

21jsonPrefix prefix = defaultOptions

32jsonPrefix prefix = defaultOptions

22 { fieldLabelModifier = modifier

33 { fieldLabelModifier = modifier

swagger2.cabal+1

@@ -22,6 +22,7 @@ library

22 Data.Swagger.Internal.Utils

23 build-depends: base >= 4.7 && < 5

24 , aeson

25+ , containers

25 , hashable

26 , hashable

26 , http-media

27 , http-media

27 , network

28 , network